February 2005 - xemacs-cvs＠xemacs.org - XEmacs Mailing List Archives

CVS update: MODIFIED: src, data.c, extents.c, lstream.c, number-gmp.h, rangetab.c, window.c ... 20 years, 2 months

CVS Monitor

User: james Date: 05/02/03 17:14:15 Modified: xemacs/src ChangeLog alloc.c buffer.c bytecode.c console.c data.c device.c dumper.c elhash.c eval.c events.c extents.c file-coding.c frame.c glyphs.c lrecord.h lstream.c marker.c mule-charset.c mule-coding.c number-gmp.h number.c objects.c profile.c rangetab.c redisplay.c specifier.c unicode.c window.c Log: Commit Olivier Galibert's dumper updates for bignums and use them. See xemacs-patches message with ID <ps8y685c6p.fsf(a)diannao.ittc.ku.edu>. Revision Changes Path 1.785 +39 -0 XEmacs/xemacs/src/ChangeLog (In the diff below, changes in quantity of whitespace are not shown.) Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/ChangeLog,v retrieving revision 1.784 retrieving revision 1.785 diff -u -b -r1.784 -r1.785 --- ChangeLog 2005/02/03 07:11:26 1.784 +++ ChangeLog 2005/02/03 16:14:02 1.785 ＠＠ -1,3 +1,42 ＠＠ +2005-02-01 Jerry James <james(a)xemacs.org> + + * dumper.c: Olivier Galibert's changes to enable dumping data via + a Java-like serialization/deserialization process. + + * number.c: OG's bignum conversion functions. Also, use the + dumping capability to initialize bigfloat-max-prec sanely. + + * alloc.c: + * buffer.c: + * bytecode.c: + * console.c: + * data.c: + * device.c: + * elhash.c: + * eval.c: + * events.c: + * extents.c: + * file-coding.c: + * frame.c: + * glyphs.c: + * lstream.c: + * marker.c: + * mule-charset.c: + * mule-coding.c: + * objects.c: + * profile.c: + * rangetab.c: + * redisplay.c: + * specifier.c: + * unicode.c: + * window.c: + Add curly braces to the data2 arg of each memory_description + initializer. Add a union member name to each reference to data2. + + * lrecord.h: Ditto. OG changes to add and document + XD_OPAQUE_PTR_CONVERTIBLE and XD_OPAQUE_DATA_CONVERTIBLE. Add + memory_contents_description to solve pointer aliasing problems. + 2005-02-02 Ben Wing <ben(a)xemacs.org> * lread.c: 1.106 +8 -7 XEmacs/xemacs/src/alloc.c (In the diff below, changes in quantity of whitespace are not shown.) Index: alloc.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/alloc.c,v retrieving revision 1.105 retrieving revision 1.106 diff -u -b -r1.105 -r1.106 --- alloc.c 2005/01/29 09:15:58 1.105 +++ alloc.c 2005/02/03 16:14:04 1.106 ＠＠ -2662,7 +2662,7 ＠＠ */ const struct memory_description free_description[] = { - { XD_LISP_OBJECT, offsetof (struct free_lcrecord_header, chain), 0, 0, + { XD_LISP_OBJECT, offsetof (struct free_lcrecord_header, chain), 0, { 0 }, XD_FLAG_FREE_LISP_OBJECT }, { XD_END } }; ＠＠ -2674,7 +2674,7 ＠＠ struct free_lcrecord_header); const struct memory_description lcrecord_list_description[] = { - { XD_LISP_OBJECT, offsetof (struct lcrecord_list, free), 0, 0, + { XD_LISP_OBJECT, offsetof (struct lcrecord_list, free), 0, { 0 }, XD_FLAG_FREE_LISP_OBJECT }, { XD_END } }; ＠＠ -3152,7 +3152,8 ＠＠ return (val * lispdesc_block_size - (rdata, lispdesc_indirect_description (obj, desc1->data2))); + (rdata, + lispdesc_indirect_description (obj, desc1->data2.descr))); } case XD_OPAQUE_DATA_PTR: return sizeof (void *); ＠＠ -3162,7 +3163,7 ＠＠ description, use it; else compute size based on current union constant. */ const struct sized_memory_description *sdesc = - lispdesc_indirect_description (obj, desc1->data2); + lispdesc_indirect_description (obj, desc1->data2.descr); if (sdesc->size) return sdesc->size; else ＠＠ -3179,7 +3180,7 ＠＠ description, use it; else compute size based on maximum of all possible structures. */ const struct sized_memory_description *sdesc = - lispdesc_indirect_description (obj, desc1->data2); + lispdesc_indirect_description (obj, desc1->data2.descr); if (sdesc->size) return sdesc->size; else ＠＠ -3520,7 +3521,7 ＠＠ EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, data); const struct sized_memory_description *sdesc = - lispdesc_indirect_description (data, desc1->data2); + lispdesc_indirect_description (data, desc1->data2.descr); const char *dobj = * (const char **) rdata; if (dobj) mark_struct_contents (dobj, sdesc, count); ＠＠ -3531,7 +3532,7 ＠＠ EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, data); const struct sized_memory_description *sdesc = - lispdesc_indirect_description (data, desc1->data2); + lispdesc_indirect_description (data, desc1->data2.descr); mark_struct_contents (rdata, sdesc, count); break; 1.70 +2 -2 XEmacs/xemacs/src/buffer.c (In the diff below, changes in quantity of whitespace are not shown.) Index: buffer.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/buffer.c,v retrieving revision 1.69 retrieving revision 1.70 diff -u -b -r1.69 -r1.70 --- buffer.c 2005/01/24 23:33:47 1.69 +++ buffer.c 2005/02/03 16:14:04 1.70 ＠＠ -245,9 +245,9 ＠＠ { XD_LISP_OBJECT, offsetof (struct buffer, extent_info) }, { XD_BLOCK_PTR, offsetof (struct buffer, text), - 1, &buffer_text_description }, + 1, { &buffer_text_description } }, { XD_BLOCK_PTR, offsetof (struct buffer, syntax_cache), - 1, &syntax_cache_description }, + 1, { &syntax_cache_description } }, { XD_LISP_OBJECT, offsetof (struct buffer, indirect_children) }, { XD_LISP_OBJECT, offsetof (struct buffer, base_buffer) }, 1.46 +1 -1 XEmacs/xemacs/src/bytecode.c (In the diff below, changes in quantity of whitespace are not shown.) Index: bytecode.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/bytecode.c,v retrieving revision 1.45 retrieving revision 1.46 diff -u -b -r1.45 -r1.46 --- bytecode.c 2005/01/29 09:15:59 1.45 +++ bytecode.c 2005/02/03 16:14:04 1.46 ＠＠ -2180,7 +2180,7 ＠＠ static const struct memory_description compiled_function_description[] = { { XD_INT, offsetof (Lisp_Compiled_Function, args_in_array) }, { XD_BLOCK_PTR, offsetof (Lisp_Compiled_Function, args), - XD_INDIRECT (0, 0), &lisp_object_description }, + XD_INDIRECT (0, 0), { &lisp_object_description } }, { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) }, { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) }, { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) }, 1.40 +6 -5 XEmacs/xemacs/src/console.c (In the diff below, changes in quantity of whitespace are not shown.) Index: console.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/console.c,v retrieving revision 1.39 retrieving revision 1.40 diff -u -b -r1.39 -r1.40 --- console.c 2005/01/24 23:33:48 1.39 +++ console.c 2005/02/03 16:14:04 1.40 ＠＠ -115,9 +115,9 ＠＠ static const struct memory_description console_data_description_1 []= { #ifdef HAVE_TTY - { XD_BLOCK_PTR, tty_console, 1, &tty_console_data_description}, + { XD_BLOCK_PTR, tty_console, 1, { &tty_console_data_description} }, #endif - { XD_BLOCK_PTR, stream_console, 1, &stream_console_data_description}, + { XD_BLOCK_PTR, stream_console, 1, { &stream_console_data_description} }, { XD_END } }; ＠＠ -130,9 +130,9 ＠＠ #define MARKED_SLOT(x) { XD_LISP_OBJECT, offsetof (struct console, x) }, #include "conslots.h" { XD_BLOCK_PTR, offsetof (struct console, conmeths), 1, - &console_methods_description }, + { &console_methods_description } }, { XD_UNION, offsetof (struct console, console_data), - XD_INDIRECT (0, 0), &console_data_description }, + XD_INDIRECT (0, 0), { &console_data_description } }, { XD_END } }; ＠＠ -1227,7 +1227,8 ＠＠ static const struct memory_description cte_description_1[] = { { XD_LISP_OBJECT, offsetof (console_type_entry, symbol) }, - { XD_BLOCK_PTR, offsetof (console_type_entry, meths), 1, &console_methods_description }, + { XD_BLOCK_PTR, offsetof (console_type_entry, meths), 1, + { &console_methods_description } }, { XD_END } }; 1.62 +5 -5 XEmacs/xemacs/src/data.c (In the diff below, changes in quantity of whitespace are not shown.) Index: data.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/data.c,v retrieving revision 1.61 retrieving revision 1.62 diff -u -b -r1.61 -r1.62 --- data.c 2005/01/24 23:33:49 1.61 +++ data.c 2005/02/03 16:14:04 1.62 ＠＠ -2589,9 +2589,9 ＠＠ static const struct memory_description weak_list_description[] = { { XD_LISP_OBJECT, offsetof (struct weak_list, list), - 0, 0, XD_FLAG_NO_KKCC }, + 0, { 0 }, XD_FLAG_NO_KKCC }, { XD_LO_LINK, offsetof (struct weak_list, next_weak), - 0, 0, XD_FLAG_NO_KKCC }, + 0, { 0 }, XD_FLAG_NO_KKCC }, { XD_END } }; ＠＠ -3299,11 +3299,11 ＠＠ is marked here. */ static const struct memory_description ephemeron_description[] = { { XD_LISP_OBJECT, offsetof(struct ephemeron, key), - 0, 0, XD_FLAG_NO_KKCC }, + 0, { 0 }, XD_FLAG_NO_KKCC }, { XD_LISP_OBJECT, offsetof(struct ephemeron, cons_chain), - 0, 0, XD_FLAG_NO_KKCC }, + 0, { 0 }, XD_FLAG_NO_KKCC }, { XD_LISP_OBJECT, offsetof(struct ephemeron, value), - 0, 0, XD_FLAG_NO_KKCC }, + 0, { 0 }, XD_FLAG_NO_KKCC }, { XD_END } }; 1.33 +6 -6 XEmacs/xemacs/src/device.c (In the diff below, changes in quantity of whitespace are not shown.) Index: device.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/device.c,v retrieving revision 1.32 retrieving revision 1.33 diff -u -b -r1.32 -r1.33 --- device.c 2004/11/04 23:06:20 1.32 +++ device.c 2005/02/03 16:14:04 1.33 ＠＠ -93,14 +93,14 ＠＠ static const struct memory_description device_data_description_1 []= { #ifdef HAVE_GTK - { XD_BLOCK_PTR, gtk_console, 1, &gtk_device_data_description}, + { XD_BLOCK_PTR, gtk_console, 1, { &gtk_device_data_description} }, #endif #ifdef HAVE_MS_WINDOWS - { XD_BLOCK_PTR, mswindows_console, 1, &mswindows_device_data_description}, - { XD_BLOCK_PTR, msprinter_console, 1, &msprinter_device_data_description}, + { XD_BLOCK_PTR, mswindows_console, 1, { &mswindows_device_data_description} }, + { XD_BLOCK_PTR, msprinter_console, 1, { &msprinter_device_data_description} }, #endif #ifdef HAVE_X_WINDOWS - { XD_BLOCK_PTR, x_console, 1, &x_device_data_description}, + { XD_BLOCK_PTR, x_console, 1, { &x_device_data_description} }, #endif { XD_END } }; ＠＠ -115,9 +115,9 ＠＠ #include "devslots.h" { XD_BLOCK_PTR, offsetof (struct device, devmeths), 1, - &console_methods_description }, + { &console_methods_description } }, { XD_UNION, offsetof (struct device, device_data), - XD_INDIRECT (0, 0), &device_data_description }, + XD_INDIRECT (0, 0), { &device_data_description } }, { XD_END } }; 1.23 +260 -9 XEmacs/xemacs/src/dumper.c (In the diff below, changes in quantity of whitespace are not shown.) Index: dumper.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/dumper.c,v retrieving revision 1.22 retrieving revision 1.23 diff -u -b -r1.22 -r1.23 --- dumper.c 2005/01/24 23:33:50 1.22 +++ dumper.c 2005/02/03 16:14:05 1.23 ＠＠ -1,5 +1,5 ＠＠ /* Portable data dumper for XEmacs. - Copyright (C) 1999-2000 Olivier Galibert + Copyright (C) 1999-2000,2004 Olivier Galibert Copyright (C) 2001 Martin Buchholz Copyright (C) 2001, 2002, 2003, 2004 Ben Wing. ＠＠ -78,6 +78,57 ＠＠ typedef struct { + const void *object; + void *data; + Bytecount size; + EMACS_INT offset; + EMACS_INT dest_offset; + EMACS_INT save_offset; + const struct opaque_convert_functions *fcts; +} pdump_cv_data_info; + +typedef struct +{ + Dynarr_declare (pdump_cv_data_info); +} pdump_cv_data_info_dynarr; + +typedef struct +{ + EMACS_INT dest_offset; + EMACS_INT save_offset; + Bytecount size; +} pdump_cv_data_dump_info; + +typedef struct +{ + const void *object; + void *data; + Bytecount size; + EMACS_INT index; + EMACS_INT save_offset; + const struct opaque_convert_functions *fcts; +} pdump_cv_ptr_info; + +typedef struct +{ + Dynarr_declare (pdump_cv_ptr_info); +} pdump_cv_ptr_info_dynarr; + +typedef struct +{ + EMACS_INT save_offset; + Bytecount size; +} pdump_cv_ptr_dump_info; + +typedef struct +{ + EMACS_INT save_offset; + Bytecount size; + void *adr; +} pdump_cv_ptr_load_info; + +typedef struct +{ Lisp_Object *address; Lisp_Object value; } pdump_static_Lisp_Object; ＠＠ -92,6 +143,8 ＠＠ static pdump_root_block_ptr_dynarr *pdump_root_block_ptrs; static Lisp_Object_ptr_dynarr *pdump_root_lisp_objects; static Lisp_Object_ptr_dynarr *pdump_weak_object_chains; +static pdump_cv_data_info_dynarr *pdump_cv_data; +static pdump_cv_ptr_info_dynarr *pdump_cv_ptr; /* Mark SIZE bytes at non-heap address BLOCKADDR for dumping, described by DESC. Called by outside callers during XEmacs initialization. */ ＠＠ -210,7 +263,10 ＠＠ /* The structure of the dump file looks like this: 0 - header - dumped objects - stab_offset - nb_root_block_ptrs*struct(void *, adr) + stab_offset - nb_cv_data*struct(dest, adr) for in-object externally + represented data + - nb_cv_ptr*(adr) for pointed-to externally represented data + - nb_root_block_ptrs*struct(void *, adr) for global pointers to heap blocks - nb_root_blocks*struct(void *, size, info) for global data-segment blocks to restore ＠＠ -231,12 +287,17 ＠＠ EMACS_UINT reloc_address; int nb_root_block_ptrs; int nb_root_blocks; + int nb_cv_data; + int nb_cv_ptr; } pdump_header; Rawbyte *pdump_start; Rawbyte *pdump_end; static Bytecount pdump_length; +static pdump_cv_data_dump_info *pdump_loaded_cv_data; +static pdump_cv_ptr_load_info *pdump_loaded_cv_ptr; + #ifdef WIN32_NATIVE /* Handle for the dump file */ static HANDLE pdump_hFile = INVALID_HANDLE_VALUE; ＠＠ -449,6 +510,16 ＠＠ return &pdump_desc_table.list[pdump_desc_table.count++].list; } +static pdump_cv_ptr_info * +pdump_find_in_cv_ptr_dynarr(const void *object) +{ + int i; + for (i = 0; i < Dynarr_length (pdump_cv_ptr); i++) + if (Dynarr_at (pdump_cv_ptr, i).object == object) + return Dynarr_atp (pdump_cv_ptr, i); + return 0; +} + static struct { struct lrecord_header *obj; ＠＠ -608,7 +679,7 ＠＠ EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, data); const struct sized_memory_description *sdesc = - lispdesc_indirect_description (data, desc1->data2); + lispdesc_indirect_description (data, desc1->data2.descr); const Rawbyte *dobj = *(const Rawbyte **)rdata; if (dobj) pdump_register_block (dobj, sdesc->size, sdesc->description, ＠＠ -620,7 +691,7 ＠＠ EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, data); const struct sized_memory_description *sdesc = - lispdesc_indirect_description (data, desc1->data2); + lispdesc_indirect_description (data, desc1->data2.descr); pdump_register_block_contents (rdata, sdesc->size, sdesc->description, count); ＠＠ -632,6 +703,29 ＠＠ if (desc1) goto union_switcheroo; break; + case XD_OPAQUE_PTR_CONVERTIBLE: + { + pdump_cv_ptr_info info; + info.object = *(void **)rdata; + info.fcts = desc1->data2.funcs; + if (!pdump_find_in_cv_ptr_dynarr (info.object)) + { + info.fcts->convert(info.object, &info.data, &info.size); + Dynarr_add (pdump_cv_ptr, info); + } + break; + } + case XD_OPAQUE_DATA_CONVERTIBLE: + { + pdump_cv_data_info info; + info.object = data; + info.offset = offset; + info.fcts = desc1->data2.funcs; + + info.fcts->convert(rdata, &info.data, &info.size); + Dynarr_add (pdump_cv_data, info); + break; + } default: pdump_unsupported_dump_type (desc1->type, 1); ＠＠ -726,6 +820,7 ＠＠ } } + /* Store the already-calculated new pointer offsets for all pointers in the COUNT contiguous blocks of memory, each described by DESC and of size SIZE, whose original is located at ORIG_DATA and the modifiable copy at ＠＠ -876,7 +971,7 ＠＠ EMACS_INT num = lispdesc_indirect_count (desc1->data1, desc, orig_data); const struct sized_memory_description *sdesc = - lispdesc_indirect_description (orig_data, desc1->data2); + lispdesc_indirect_description (orig_data, desc1->data2.descr); pdump_store_new_pointer_offsets (num, rdata, ＠＠ -895,6 +990,14 ＠＠ goto union_switcheroo; break; + case XD_OPAQUE_PTR_CONVERTIBLE: + *(EMACS_INT *)rdata = pdump_find_in_cv_ptr_dynarr (*(void **)rdata)->index; + break; + + case XD_OPAQUE_DATA_CONVERTIBLE: + /* in-object, nothing to do */ + break; + default: pdump_unsupported_dump_type (desc1->type, 0); } ＠＠ -1015,7 +1118,7 ＠＠ data); int j; const struct sized_memory_description *sdesc = - lispdesc_indirect_description (data, desc1->data2); + lispdesc_indirect_description (data, desc1->data2.descr); Bytecount size = lispdesc_block_size (rdata, sdesc); /* Note: We are recursing over data in the block itself */ ＠＠ -1032,6 +1135,28 ＠＠ goto union_switcheroo; break; + case XD_OPAQUE_PTR_CONVERTIBLE: + { + pdump_cv_ptr_load_info *p = pdump_loaded_cv_ptr + *(EMACS_INT *)rdata; + if (!p->adr) + p->adr = desc1->data2.funcs->deconvert(0, pdump_start + + p->save_offset, p->size); + *(void **)rdata = p->adr; + break; + } + + case XD_OPAQUE_DATA_CONVERTIBLE: + { + EMACS_INT dest_offset = (Rawbyte *)rdata - pdump_start; + pdump_cv_data_dump_info *p; + + for(p = pdump_loaded_cv_data; p->dest_offset != dest_offset; p++); + + desc1->data2.funcs->deconvert(rdata, pdump_start + p->save_offset, + p->size); + break; + } + default: pdump_unsupported_dump_type (desc1->type, 0); } ＠＠ -1049,6 +1174,39 ＠＠ cur_offset += size; } +/* Write out to global file descriptor PDUMP_OUT the result of an + external element. It's just opaque data. */ + +static void +pdump_dump_cv_data (pdump_cv_data_info *elt) +{ + retry_fwrite (elt->data, elt->size, 1, pdump_out); +} + +static void +pdump_dump_cv_ptr (pdump_cv_ptr_info *elt) +{ + retry_fwrite (elt->data, elt->size, 1, pdump_out); +} + +static void +pdump_allocate_offset_cv_data (pdump_cv_data_info *elt) +{ + elt->save_offset = cur_offset; + if (elt->size>max_size) + max_size = elt->size; + cur_offset += elt->size; +} + +static void +pdump_allocate_offset_cv_ptr (pdump_cv_ptr_info *elt) +{ + elt->save_offset = cur_offset; + if (elt->size>max_size) + max_size = elt->size; + cur_offset += elt->size; +} + /* Traverse through all the heap blocks, once the "register" stage of dumping has finished. To compress space as much as possible, we logically sort all blocks by alignment, hitting all blocks with ＠＠ -1081,7 +1239,9 ＠＠ static void pdump_scan_by_alignment (void (*f)(pdump_block_list_elt *, - const struct memory_description *)) + const struct memory_description *), + void (*g)(pdump_cv_data_info *), + void (*h)(pdump_cv_ptr_info *)) { int align; ＠＠ -1106,7 +1266,32 ＠＠ for (elt = pdump_opaque_data_list.first; elt; elt = elt->next) if (pdump_size_to_align (elt->size) == align) f (elt, 0); + + for (i=0; i < Dynarr_length (pdump_cv_data); i++) + if (pdump_size_to_align (Dynarr_atp (pdump_cv_data, i)->size) == align) + g (Dynarr_atp (pdump_cv_data, i)); + + for (i=0; i < Dynarr_length (pdump_cv_ptr); i++) + if (pdump_size_to_align (Dynarr_atp (pdump_cv_ptr, i)->size) == align) + h (Dynarr_atp (pdump_cv_ptr, i)); + } +} + +static void +pdump_dump_cv_data_info (void) +{ + int i; + Elemcount count = Dynarr_length (pdump_cv_data); + pdump_cv_data_dump_info *data = alloca_array (pdump_cv_data_dump_info, count); + for (i = 0; i < count; i++) + { + data[i].dest_offset = Dynarr_at (pdump_cv_data, i).dest_offset; + data[i].save_offset = Dynarr_at (pdump_cv_data, i).save_offset; + data[i].size = Dynarr_at (pdump_cv_data, i).size; } + + PDUMP_ALIGN_OUTPUT (pdump_cv_data_dump_info); + retry_fwrite (data, sizeof (pdump_cv_data_dump_info), count, pdump_out); } /* Dump out the root block pointers, part of stage 3 (the "WRITE" stage) of ＠＠ -1115,6 +1300,22 ＠＠ offset into the dumped data. */ static void +pdump_dump_cv_ptr_info (void) +{ + int i; + Elemcount count = Dynarr_length (pdump_cv_ptr); + pdump_cv_ptr_dump_info *data = alloca_array (pdump_cv_ptr_dump_info, count); + for (i = 0; i < count; i++) + { + data[i].save_offset = Dynarr_at (pdump_cv_ptr, i).save_offset; + data[i].size = Dynarr_at (pdump_cv_ptr, i).size; + } + + PDUMP_ALIGN_OUTPUT (pdump_cv_ptr_dump_info); + retry_fwrite (data, sizeof (pdump_cv_ptr_dump_info), count, pdump_out); +} + +static void pdump_dump_root_block_ptrs (void) { int i; ＠＠ -1436,6 +1637,9 ＠＠ pdump_opaque_data_list.count = 0; pdump_depth = 0; + pdump_cv_data = Dynarr_new2 (pdump_cv_data_info_dynarr, pdump_cv_data_info); + pdump_cv_ptr = Dynarr_new2 (pdump_cv_ptr_info_dynarr, pdump_cv_ptr_info); + /* (I) The "register" stage: Note all heap memory blocks to be relocated */ ＠＠ -1495,13 +1699,17 ＠＠ header.reloc_address = 0; header.nb_root_block_ptrs = Dynarr_length (pdump_root_block_ptrs); header.nb_root_blocks = Dynarr_length (pdump_root_blocks); + header.nb_cv_data = Dynarr_length (pdump_cv_data); + header.nb_cv_ptr = Dynarr_length (pdump_cv_ptr); cur_offset = MAX_ALIGN_SIZE (sizeof (header)); max_size = 0; /* (2) Traverse all heap blocks and compute their offsets; keep track of maximum block size seen */ - pdump_scan_by_alignment (pdump_allocate_offset); + pdump_scan_by_alignment (pdump_allocate_offset, + pdump_allocate_offset_cv_data, + pdump_allocate_offset_cv_ptr); cur_offset = MAX_ALIGN_SIZE (cur_offset); header.stab_offset = cur_offset; ＠＠ -1536,11 +1744,37 ＠＠ retry_fwrite (&header, sizeof (header), 1, pdump_out); PDUMP_ALIGN_OUTPUT (max_align_t); + + for (i = 0; i < Dynarr_length (pdump_cv_data); i++) + { + pdump_cv_data_info *elt = Dynarr_atp (pdump_cv_data, i); + elt->dest_offset = + pdump_get_block (elt->object)->save_offset + elt->offset; + } + + for (i = 0; i < Dynarr_length (pdump_cv_ptr); i++) + Dynarr_at (pdump_cv_ptr, i).index = i; + + pdump_scan_by_alignment (pdump_dump_data, pdump_dump_cv_data, pdump_dump_cv_ptr); - pdump_scan_by_alignment (pdump_dump_data); + for (i = 0; i < Dynarr_length (pdump_cv_data); i++) + { + pdump_cv_data_info *elt = Dynarr_atp (pdump_cv_data, i); + if(elt->fcts->convert_free) + elt->fcts->convert_free(elt->object, elt->data, elt->size); + } + for (i = 0; i < Dynarr_length (pdump_cv_ptr); i++) + { + pdump_cv_ptr_info *elt = Dynarr_atp (pdump_cv_ptr, i); + if(elt->fcts->convert_free) + elt->fcts->convert_free(elt->object, elt->data, elt->size); + } + fseek (pdump_out, header.stab_offset, SEEK_SET); + pdump_dump_cv_data_info (); + pdump_dump_cv_ptr_info (); pdump_dump_root_block_ptrs (); pdump_dump_root_blocks (); pdump_dump_rtables (); ＠＠ -1583,6 +1817,23 ＠＠ delta = ((EMACS_INT) pdump_start) - header->reloc_address; p = pdump_start + header->stab_offset; + + /* Get the cv_data array */ + p = (char *) ALIGN_PTR (p, pdump_cv_data_dump_info); + pdump_loaded_cv_data = (pdump_cv_data_dump_info *)p; + p += header->nb_cv_data*sizeof(pdump_cv_data_dump_info); + + /* Build the cv_ptr array */ + p = (char *) ALIGN_PTR (p, pdump_cv_ptr_dump_info); + pdump_loaded_cv_ptr = + alloca_array (pdump_cv_ptr_load_info, header->nb_cv_ptr); + for (i = 0; i < header->nb_cv_ptr; i++) + { + pdump_cv_ptr_dump_info info = PDUMP_READ (p, pdump_cv_ptr_dump_info); + pdump_loaded_cv_ptr[i].save_offset = info.save_offset; + pdump_loaded_cv_ptr[i].size = info.size; + pdump_loaded_cv_ptr[i].adr = 0; + } /* Put back the pdump_root_block_ptrs */ p = (Rawbyte *) ALIGN_PTR (p, pdump_static_pointer); 1.40 +3 -3 XEmacs/xemacs/src/elhash.c (In the diff below, changes in quantity of whitespace are not shown.) Index: elhash.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/elhash.c,v retrieving revision 1.39 retrieving revision 1.40 diff -u -b -r1.39 -r1.40 --- elhash.c 2005/01/24 23:33:51 1.39 +++ elhash.c 2005/02/03 16:14:05 1.40 ＠＠ -452,8 +452,8 ＠＠ /* Note: XD_INDIRECT in this table refers to the surrounding table, and so this will work. */ { XD_BLOCK_PTR, HASH_TABLE_NON_WEAK, XD_INDIRECT (0, 1), - &htentry_description }, - { XD_BLOCK_PTR, 0, XD_INDIRECT (0, 1), &htentry_description, + { &htentry_description } }, + { XD_BLOCK_PTR, 0, XD_INDIRECT (0, 1), { &htentry_description }, XD_FLAG_UNION_DEFAULT_ENTRY | XD_FLAG_NO_KKCC }, { XD_END } }; ＠＠ -467,7 +467,7 ＠＠ { XD_ELEMCOUNT, offsetof (Lisp_Hash_Table, size) }, { XD_INT, offsetof (Lisp_Hash_Table, weakness) }, { XD_UNION, offsetof (Lisp_Hash_Table, hentries), XD_INDIRECT (1, 0), - &htentry_union_description }, + { &htentry_union_description } }, { XD_LO_LINK, offsetof (Lisp_Hash_Table, next_weak) }, { XD_END } }; 1.87 +1 -1 XEmacs/xemacs/src/eval.c (In the diff below, changes in quantity of whitespace are not shown.) Index: eval.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/eval.c,v retrieving revision 1.86 retrieving revision 1.87 diff -u -b -r1.86 -r1.87 --- eval.c 2005/01/29 09:15:59 1.86 +++ eval.c 2005/02/03 16:14:05 1.87 ＠＠ -429,7 +429,7 ＠＠ } static const struct memory_description subr_description[] = { - { XD_DOC_STRING, offsetof (Lisp_Subr, doc), 0, 0, XD_FLAG_NO_KKCC }, + { XD_DOC_STRING, offsetof (Lisp_Subr, doc), 0, { 0 }, XD_FLAG_NO_KKCC }, { XD_END } }; 1.65 +11 -11 XEmacs/xemacs/src/events.c (In the diff below, changes in quantity of whitespace are not shown.) Index: events.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/events.c,v retrieving revision 1.64 retrieving revision 1.65 diff -u -b -r1.64 -r1.65 --- events.c 2005/01/24 23:33:53 1.64 +++ events.c 2005/02/03 16:14:05 1.65 ＠＠ -189,16 +189,16 ＠＠ }; static const struct memory_description event_data_description_1 [] = { - { XD_BLOCK_ARRAY, key_press_event, 1, &key_data_description }, - { XD_BLOCK_ARRAY, button_press_event, 1, &button_data_description }, - { XD_BLOCK_ARRAY, button_release_event, 1, &button_data_description }, - { XD_BLOCK_ARRAY, pointer_motion_event, 1, &motion_data_description }, - { XD_BLOCK_ARRAY, process_event, 1, &process_data_description }, - { XD_BLOCK_ARRAY, timeout_event, 1, &timeout_data_description }, - { XD_BLOCK_ARRAY, magic_event, 1, &magic_data_description }, - { XD_BLOCK_ARRAY, magic_eval_event, 1, &magic_eval_data_description }, - { XD_BLOCK_ARRAY, eval_event, 1, &eval_data_description }, - { XD_BLOCK_ARRAY, misc_user_event, 1, &misc_user_data_description }, + { XD_BLOCK_ARRAY, key_press_event, 1, { &key_data_description } }, + { XD_BLOCK_ARRAY, button_press_event, 1, { &button_data_description } }, + { XD_BLOCK_ARRAY, button_release_event, 1, { &button_data_description } }, + { XD_BLOCK_ARRAY, pointer_motion_event, 1, { &motion_data_description } }, + { XD_BLOCK_ARRAY, process_event, 1, { &process_data_description } }, + { XD_BLOCK_ARRAY, timeout_event, 1, { &timeout_data_description } }, + { XD_BLOCK_ARRAY, magic_event, 1, { &magic_data_description } }, + { XD_BLOCK_ARRAY, magic_eval_event, 1, { &magic_eval_data_description } }, + { XD_BLOCK_ARRAY, eval_event, 1, { &eval_data_description } }, + { XD_BLOCK_ARRAY, misc_user_event, 1, { &misc_user_data_description } }, { XD_END } }; ＠＠ -211,7 +211,7 ＠＠ { XD_LISP_OBJECT, offsetof (struct Lisp_Event, next) }, { XD_LISP_OBJECT, offsetof (struct Lisp_Event, channel) }, { XD_UNION, offsetof (struct Lisp_Event, event), - XD_INDIRECT (0, 0), &event_data_description }, + XD_INDIRECT (0, 0), { &event_data_description } }, { XD_END } }; 1.56 +16 -12 XEmacs/xemacs/src/extents.c (In the diff below, changes in quantity of whitespace are not shown.) Index: extents.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/extents.c,v retrieving revision 1.55 retrieving revision 1.56 diff -u -b -r1.55 -r1.56 --- extents.c 2005/01/26 05:11:11 1.55 +++ extents.c 2005/02/03 16:14:06 1.56 ＠＠ -1029,7 +1029,7 ＠＠ static const struct memory_description gap_array_marker_description_1[] = { { XD_BLOCK_PTR, offsetof (Gap_Array_Marker, next), 1, - &gap_array_marker_description }, + { &gap_array_marker_description } }, { XD_END } }; ＠＠ -1043,11 +1043,11 ＠＠ { XD_INT, offsetof (Gap_Array, offset_past_gap) }, { XD_INT, offsetof (Gap_Array, els_past_gap) }, { XD_BLOCK_PTR, offsetof (Gap_Array, markers), 1, - &gap_array_marker_description, XD_FLAG_NO_KKCC }, + { &gap_array_marker_description }, XD_FLAG_NO_KKCC }, { XD_BLOCK_ARRAY, offsetof (Gap_Array, array), XD_INDIRECT (0, 0), - &lisp_object_description }, + { &lisp_object_description } }, { XD_BLOCK_ARRAY, XD_INDIRECT (1, offsetof (Gap_Array, array)), - XD_INDIRECT (2, 0), &lisp_object_description }, + XD_INDIRECT (2, 0), { &lisp_object_description } }, { XD_END } }; ＠＠ -1060,9 +1060,9 ＠＠ static const struct memory_description extent_list_marker_description_1[] = { { XD_BLOCK_PTR, offsetof (Extent_List_Marker, m), 1, - &gap_array_marker_description }, + { &gap_array_marker_description } }, { XD_BLOCK_PTR, offsetof (Extent_List_Marker, next), 1, - &extent_list_marker_description }, + { &extent_list_marker_description } }, { XD_END } }; ＠＠ -1072,9 +1072,12 ＠＠ }; static const struct memory_description extent_list_description_1[] = { - { XD_BLOCK_PTR, offsetof (Extent_List, start), 1, &lispobj_gap_array_description }, - { XD_BLOCK_PTR, offsetof (Extent_List, end), 1, &lispobj_gap_array_description, XD_FLAG_NO_KKCC }, - { XD_BLOCK_PTR, offsetof (Extent_List, markers), 1, &extent_list_marker_description, XD_FLAG_NO_KKCC }, + { XD_BLOCK_PTR, offsetof (Extent_List, start), 1, + { &lispobj_gap_array_description } }, + { XD_BLOCK_PTR, offsetof (Extent_List, end), 1, + { &lispobj_gap_array_description }, XD_FLAG_NO_KKCC }, + { XD_BLOCK_PTR, offsetof (Extent_List, markers), 1, + { &extent_list_marker_description }, XD_FLAG_NO_KKCC }, { XD_END } }; ＠＠ -1084,7 +1087,8 ＠＠ }; static const struct memory_description stack_of_extents_description_1[] = { - { XD_BLOCK_PTR, offsetof (Stack_Of_Extents, extents), 1, &extent_list_description }, + { XD_BLOCK_PTR, offsetof (Stack_Of_Extents, extents), 1, + { &extent_list_description } }, { XD_END } }; ＠＠ -1095,9 +1099,9 ＠＠ static const struct memory_description extent_info_description [] = { { XD_BLOCK_PTR, offsetof (struct extent_info, extents), 1, - &extent_list_description }, + { &extent_list_description } }, { XD_BLOCK_PTR, offsetof (struct extent_info, soe), 1, - &stack_of_extents_description, XD_FLAG_NO_KKCC }, + { &stack_of_extents_description }, XD_FLAG_NO_KKCC }, { XD_END } }; 1.44 +13 -10 XEmacs/xemacs/src/file-coding.c (In the diff below, changes in quantity of whitespace are not shown.) Index: file-coding.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/file-coding.c,v retrieving revision 1.43 retrieving revision 1.44 diff -u -b -r1.43 -r1.44 --- file-coding.c 2005/01/29 09:06:40 1.43 +++ file-coding.c 2005/02/03 16:14:06 1.44 ＠＠ -106,7 +106,8 ＠＠ static coding_system_type_entry_dynarr *the_coding_system_type_entry_dynarr; static const struct memory_description cste_description_1[] = { - { XD_BLOCK_PTR, offsetof (coding_system_type_entry, meths), 1, &coding_system_methods_description }, + { XD_BLOCK_PTR, offsetof (coding_system_type_entry, meths), 1, + { &coding_system_methods_description } }, { XD_END } }; ＠＠ -171,7 +172,7 ＠＠ = { { XD_BLOCK_PTR, offsetof (struct detector, cats), 1, - &detector_category_dynarr_description }, + { &detector_category_dynarr_description } }, { XD_END } }; ＠＠ -346,13 +347,13 ＠＠ static const struct memory_description coding_system_description[] = { { XD_BLOCK_PTR, offsetof (Lisp_Coding_System, methods), 1, - &coding_system_methods_description }, + { &coding_system_methods_description } }, #define MARKED_SLOT(x) { XD_LISP_OBJECT, offsetof (Lisp_Coding_System, x) }, #define MARKED_SLOT_ARRAY(slot, size) \ { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Coding_System, slot), size }, #include "coding-system-slots.h" { XD_BLOCK_ARRAY, offsetof (Lisp_Coding_System, data), 1, - coding_system_extra_description_map }, + { coding_system_extra_description_map } }, { XD_END } }; ＠＠ -1727,8 +1728,10 ＠＠ extern const struct sized_memory_description undecided_coding_stream_description; static const struct memory_description coding_stream_data_description_1 []= { - { XD_BLOCK_PTR, chain_coding_system, 1, &chain_coding_stream_description}, - { XD_BLOCK_PTR, undecided_coding_system, 1, &undecided_coding_stream_description}, + { XD_BLOCK_PTR, chain_coding_system, 1, + { &chain_coding_stream_description } }, + { XD_BLOCK_PTR, undecided_coding_system, 1, + { &undecided_coding_stream_description } }, { XD_END } }; ＠＠ -1742,7 +1745,7 ＠＠ { XD_LISP_OBJECT, offsetof (struct coding_stream, codesys) }, { XD_LISP_OBJECT, offsetof (struct coding_stream, other_end) }, { XD_UNION, offsetof (struct coding_stream, data), - XD_INDIRECT (0, 0), &coding_stream_data_description }, + XD_INDIRECT (0, 0), { &coding_stream_data_description } }, { XD_END } }; ＠＠ -2330,7 +2333,7 ＠＠ static const struct memory_description chain_coding_system_description[] = { { XD_INT, offsetof (struct chain_coding_system, count) }, { XD_BLOCK_PTR, offsetof (struct chain_coding_system, chain), - XD_INDIRECT (0, 0), &lisp_object_description }, + XD_INDIRECT (0, 0), { &lisp_object_description } }, { XD_LISP_OBJECT, offsetof (struct chain_coding_system, canonicalize_after_coding) }, { XD_END } ＠＠ -2339,7 +2342,7 ＠＠ static const struct memory_description chain_coding_stream_description_1 [] = { { XD_INT, offsetof (struct chain_coding_stream, lstream_count) }, { XD_BLOCK_PTR, offsetof (struct chain_coding_stream, lstreams), - XD_INDIRECT (0, 0), &lisp_object_description }, + XD_INDIRECT (0, 0), { &lisp_object_description } }, { XD_END } }; ＠＠ -3085,7 +3088,7 ＠＠ static const struct memory_description undecided_coding_stream_description_1 [] = { { XD_LISP_OBJECT, offsetof (struct undecided_coding_stream, actual) }, { XD_BLOCK_ARRAY, offsetof (struct undecided_coding_stream, c), - 1, &chain_coding_stream_description }, + 1, { &chain_coding_stream_description } }, { XD_END } }; 1.67 +11 -11 XEmacs/xemacs/src/frame.c (In the diff below, changes in quantity of whitespace are not shown.) Index: frame.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/frame.c,v retrieving revision 1.66 retrieving revision 1.67 diff -u -b -r1.66 -r1.67 --- frame.c 2005/01/24 23:33:56 1.66 +++ frame.c 2005/02/03 16:14:06 1.67 ＠＠ -144,13 +144,13 ＠＠ static const struct memory_description frame_data_description_1 []= { #ifdef HAVE_GTK - { XD_BLOCK_PTR, gtk_console, 1, &gtk_frame_data_description}, + { XD_BLOCK_PTR, gtk_console, 1, { &gtk_frame_data_description} }, #endif #ifdef HAVE_MS_WINDOWS - { XD_BLOCK_PTR, mswindows_console, 1, &mswindows_frame_data_description}, + { XD_BLOCK_PTR, mswindows_console, 1, { &mswindows_frame_data_description} }, #endif #ifdef HAVE_X_WINDOWS - { XD_BLOCK_PTR, x_console, 1, &x_frame_data_description}, + { XD_BLOCK_PTR, x_console, 1, { &x_frame_data_description} }, #endif { XD_END } }; ＠＠ -163,7 +163,7 ＠＠ static const struct memory_description expose_ignore_description_1 [] = { { XD_BLOCK_PTR, offsetof (struct expose_ignore, next), - 1, &expose_ignore_description }, + 1, { &expose_ignore_description } }, { XD_END } }; ＠＠ -173,7 +173,7 ＠＠ }; static const struct memory_description display_line_dynarr_pointer_description_1 []= { - { XD_BLOCK_PTR, 0, 1, &display_line_dynarr_description}, + { XD_BLOCK_PTR, 0, 1, { &display_line_dynarr_description} }, { XD_END } }; ＠＠ -189,9 +189,9 ＠＠ #include "frameslots.h" { XD_BLOCK_PTR, offsetof (struct frame, subwindow_exposures), - 1, &expose_ignore_description }, + 1, { &expose_ignore_description } }, { XD_BLOCK_PTR, offsetof (struct frame, subwindow_exposures_tail), - 1, &expose_ignore_description }, + 1, { &expose_ignore_description } }, #ifdef HAVE_SCROLLBARS { XD_LISP_OBJECT, offsetof (struct frame, sb_vcache) }, ＠＠ -199,14 +199,14 ＠＠ #endif /* HAVE_SCROLLBARS */ { XD_BLOCK_ARRAY, offsetof (struct frame, current_display_lines), - 4, &display_line_dynarr_pointer_description }, + 4, { &display_line_dynarr_pointer_description } }, { XD_BLOCK_ARRAY, offsetof (struct frame, desired_display_lines), - 4, &display_line_dynarr_pointer_description }, + 4, { &display_line_dynarr_pointer_description } }, { XD_BLOCK_PTR, offsetof (struct frame, framemeths), 1, - &console_methods_description }, + { &console_methods_description } }, { XD_UNION, offsetof (struct frame, frame_data), - XD_INDIRECT (0, 0), &frame_data_description }, + XD_INDIRECT (0, 0), { &frame_data_description } }, { XD_END } }; 1.51 +11 -8 XEmacs/xemacs/src/glyphs.c (In the diff below, changes in quantity of whitespace are not shown.) Index: glyphs.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/glyphs.c,v retrieving revision 1.50 retrieving revision 1.51 diff -u -b -r1.50 -r1.51 --- glyphs.c 2005/01/28 02:36:25 1.50 +++ glyphs.c 2005/02/03 16:14:06 1.51 ＠＠ -876,13 +876,13 ＠＠ static const struct memory_description image_instance_data_description_1 [] = { { XD_BLOCK_ARRAY, IMAGE_TEXT, - 1, &text_image_instance_description }, + 1, { &text_image_instance_description } }, { XD_BLOCK_ARRAY, IMAGE_MONO_PIXMAP, - 1, &pixmap_image_instance_description }, + 1, { &pixmap_image_instance_description } }, { XD_BLOCK_ARRAY, IMAGE_COLOR_PIXMAP, - 1, &pixmap_image_instance_description }, + 1, { &pixmap_image_instance_description } }, { XD_BLOCK_ARRAY, IMAGE_WIDGET, - 1, &subwindow_image_instance_description }, + 1, { &subwindow_image_instance_description } }, { XD_END } }; ＠＠ -898,7 +898,7 ＠＠ { XD_LISP_OBJECT, offsetof (Lisp_Image_Instance, parent) }, { XD_LISP_OBJECT, offsetof (Lisp_Image_Instance, instantiator) }, { XD_UNION, offsetof (struct Lisp_Image_Instance, u), - XD_INDIRECT (0, 0), &image_instance_data_description }, + XD_INDIRECT (0, 0), { &image_instance_data_description } }, { XD_END } }; ＠＠ -5264,7 +5264,8 ＠＠ static const struct memory_description iife_description_1[] = { { XD_LISP_OBJECT, offsetof (image_instantiator_format_entry, symbol) }, { XD_LISP_OBJECT, offsetof (image_instantiator_format_entry, device) }, - { XD_BLOCK_PTR, offsetof (image_instantiator_format_entry, meths), 1, &iim_description }, + { XD_BLOCK_PTR, offsetof (image_instantiator_format_entry, meths), 1, + { &iim_description } }, { XD_END } }; ＠＠ -5286,8 +5287,10 ＠＠ static const struct memory_description iim_description_1[] = { { XD_LISP_OBJECT, offsetof (struct image_instantiator_methods, symbol) }, { XD_LISP_OBJECT, offsetof (struct image_instantiator_methods, device) }, - { XD_BLOCK_PTR, offsetof (struct image_instantiator_methods, keywords), 1, &iiked_description }, - { XD_BLOCK_PTR, offsetof (struct image_instantiator_methods, consoles), 1, &cted_description }, + { XD_BLOCK_PTR, offsetof (struct image_instantiator_methods, keywords), 1, + { &iiked_description } }, + { XD_BLOCK_PTR, offsetof (struct image_instantiator_methods, consoles), 1, + { &cted_description } }, { XD_END } }; 1.36 +60 -8 XEmacs/xemacs/src/lrecord.h (In the diff below, changes in quantity of whitespace are not shown.) Index: lrecord.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/lrecord.h,v retrieving revision 1.35 retrieving revision 1.36 diff -u -b -r1.35 -r1.36 --- lrecord.h 2005/01/26 10:22:26 1.35 +++ lrecord.h 2005/02/03 16:14:07 1.36 ＠＠ -505,7 +505,7 ＠＠ ... { XD_INT, offsetof (Lisp_Foo, count) }, { XD_BLOCK_PTR, offsetof (Lisp_Foo, objects), - XD_INDIRECT (0, 0), &lisp_object_description }, + XD_INDIRECT (0, 0), { &lisp_object_description } }, ... }; ＠＠ -560,7 +560,7 ＠＠ const struct memory_description hash_table_description[] = { { XD_ELEMCOUNT, offsetof (Lisp_Hash_Table, size) }, { XD_BLOCK_PTR, offsetof (Lisp_Hash_Table, hentries), XD_INDIRECT (0, 1), - &htentry_description }, + { &htentry_description } }, { XD_LO_LINK, offsetof (Lisp_Hash_Table, next_weak) }, { XD_END } }; ＠＠ -580,7 +580,7 ＠＠ const struct memory_description specifier_description[] = { ... { XD_BLOCK_ARRAY, offset (Lisp_Specifier, data), 1, - specifier_extra_description_map }, + { specifier_extra_description_map } }, ... { XD_END } }; ＠＠ -648,6 +648,18 ＠＠ Pointer to undumpable data. Must be NULL when dumping. + XD_OPAQUE_PTR_CONVERTIBLE + + Pointer to data which is not directly dumpable but can be converted + to a dumpable, opaque external representation. The parameter is + a pointer to an opaque_convert_functions struct. + + XD_OPAQUE_DATA_CONVERTIBLE + + Data which is not directly dumpable but can be converted to a + dumpable, opaque external representation. The parameter is a + pointer to an opaque_convert_functions struct. + XD_BLOCK_PTR Pointer to block of described memory. (This is misnamed: It is NOT ＠＠ -786,9 +798,11 ＠＠ XD_LISP_OBJECT, XD_LO_LINK, XD_OPAQUE_PTR, + XD_OPAQUE_PTR_CONVERTIBLE, + XD_OPAQUE_DATA_CONVERTIBLE, + XD_OPAQUE_DATA_PTR, XD_BLOCK_PTR, XD_BLOCK_ARRAY, - XD_OPAQUE_DATA_PTR, XD_UNION, XD_UNION_DYNAMIC_SIZE, XD_ASCII_STRING, ＠＠ -847,12 +861,21 ＠＠ #endif }; +union memory_contents_description +{ + /* The first element is used by static initializers only. We always read + from one of the other two pointers. */ + const void *write_only; + const struct sized_memory_description *descr; + const struct opaque_convert_functions *funcs; +}; + struct memory_description { enum memory_description_type type; Bytecount offset; EMACS_INT data1; - const struct sized_memory_description *data2; + union memory_contents_description data2; /* Indicates which subsystems process this entry, plus (potentially) other flags that apply to this entry. */ int flags; ＠＠ -864,6 +887,36 ＠＠ const struct memory_description *description; }; + +struct opaque_convert_functions +{ + /* Used by XD_OPAQUE_PTR_CONVERTIBLE and + XD_OPAQUE_DATA_CONVERTIBLE */ + + /* Converter to external representation, for those objects from + external libraries that can't be directly dumped as opaque data + because they contain pointers. This is called at dump time to + convert to an opaque, pointer-less representation. + + This function must put a pointer to the opaque result in *data + and its size in *size. */ + void (*convert)(const void *object, void **data, Bytecount *size); + + /* Post-conversion cleanup. Optional (null if not provided). + + When provided it will be called post-dumping to free any storage + allocated for the conversion results. */ + void (*convert_free)(const void *object, void *data, Bytecount size); + + /* De-conversion. + + At reload time, rebuilds the object from the converted form. + "object" is 0 for the PTR case, return is ignored in the DATA + case. */ + void *(*deconvert)(void *object, void *data, Bytecount size); + +}; + extern const struct sized_memory_description lisp_object_description; #define XD_INDIRECT(val, delta) (-1 - (Bytecount) ((val) | ((delta) << 8))) ＠＠ -873,11 +926,10 ＠＠ #define XD_INDIRECT_DELTA(code) ((-1 - (code)) >> 8) #define XD_DYNARR_DESC(base_type, sub_desc) \ - { XD_BLOCK_PTR, offsetof (base_type, base), XD_INDIRECT(1, 0), sub_desc }, \ + { XD_BLOCK_PTR, offsetof (base_type, base), XD_INDIRECT(1, 0), {sub_desc} },\ { XD_INT, offsetof (base_type, cur) }, \ { XD_INT_RESET, offsetof (base_type, max), XD_INDIRECT(1, 0) } \ - /* DEFINE_LRECORD_IMPLEMENTATION is for objects with constant size. DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION is for objects whose size varies. */ ＠＠ -1605,7 +1657,7 ＠＠ EMACS_INT variant = lispdesc_indirect_count (desc1->data1, desc, data); desc1 = - lispdesc_indirect_description (data, desc1->data2)->description; + lispdesc_indirect_description (data, desc1->data2.descr)->description; for (count = 0; desc1[count].type != XD_END; count++) { 1.33 +2 -2 XEmacs/xemacs/src/lstream.c (In the diff below, changes in quantity of whitespace are not shown.) Index: lstream.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/lstream.c,v retrieving revision 1.32 retrieving revision 1.33 diff -u -b -r1.32 -r1.33 --- lstream.c 2005/01/24 23:34:02 1.32 +++ lstream.c 2005/02/03 16:14:07 1.33 ＠＠ -135,9 +135,9 ＠＠ static const struct memory_description lstream_description[] = { { XD_BLOCK_PTR, offsetof (Lstream, imp), 1, - &lstream_implementation_description }, + { &lstream_implementation_description } }, { XD_BLOCK_ARRAY, offsetof (Lstream, data), 1, - lstream_extra_description_map }, + { lstream_extra_description_map } }, { XD_END } }; 1.16 +2 -2 XEmacs/xemacs/src/marker.c (In the diff below, changes in quantity of whitespace are not shown.) Index: marker.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/marker.c,v retrieving revision 1.15 retrieving revision 1.16 diff -u -b -r1.15 -r1.16 --- marker.c 2005/01/26 10:22:26 1.15 +++ marker.c 2005/02/03 16:14:07 1.16 ＠＠ -98,8 +98,8 ＠＠ } static const struct memory_description marker_description[] = { - { XD_LISP_OBJECT, offsetof (Lisp_Marker, next), 0, 0, XD_FLAG_NO_KKCC }, - { XD_LISP_OBJECT, offsetof (Lisp_Marker, prev), 0, 0, XD_FLAG_NO_KKCC }, + { XD_LISP_OBJECT, offsetof (Lisp_Marker, next), 0, { 0 }, XD_FLAG_NO_KKCC }, + { XD_LISP_OBJECT, offsetof (Lisp_Marker, prev), 0, { 0 }, XD_FLAG_NO_KKCC }, { XD_LISP_OBJECT, offsetof (Lisp_Marker, buffer) }, { XD_END } }; 1.41 +2 -2 XEmacs/xemacs/src/mule-charset.c (In the diff below, changes in quantity of whitespace are not shown.) Index: mule-charset.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/mule-charset.c,v retrieving revision 1.40 retrieving revision 1.41 diff -u -b -r1.40 -r1.41 --- mule-charset.c 2004/11/04 23:06:42 1.40 +++ mule-charset.c 2005/02/03 16:14:07 1.41 ＠＠ -173,9 +173,9 ＠＠ { XD_LISP_OBJECT, offsetof (Lisp_Charset, reverse_direction_charset) }, { XD_LISP_OBJECT, offsetof (Lisp_Charset, ccl_program) }, { XD_UNION, offsetof (Lisp_Charset, to_unicode_table), - XD_INDIRECT (0, 0), &to_unicode_description }, + XD_INDIRECT (0, 0), { &to_unicode_description } }, { XD_UNION, offsetof (Lisp_Charset, from_unicode_table), - XD_INDIRECT (1, 0), &from_unicode_description }, + XD_INDIRECT (1, 0), { &from_unicode_description } }, { XD_END } }; 1.34 +2 -2 XEmacs/xemacs/src/mule-coding.c (In the diff below, changes in quantity of whitespace are not shown.) Index: mule-coding.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/mule-coding.c,v retrieving revision 1.33 retrieving revision 1.34 diff -u -b -r1.33 -r1.34 --- mule-coding.c 2005/01/24 23:34:04 1.33 +++ mule-coding.c 2005/02/03 16:14:07 1.34 ＠＠ -953,9 +953,9 ＠＠ { XD_LISP_OBJECT_ARRAY, offsetof (struct iso2022_coding_system, initial_charset), 4 }, { XD_BLOCK_PTR, offsetof (struct iso2022_coding_system, input_conv), - 1, &ccsd_description }, + 1, { &ccsd_description } }, { XD_BLOCK_PTR, offsetof (struct iso2022_coding_system, output_conv), - 1, &ccsd_description }, + 1, { &ccsd_description } }, { XD_END } }; 1.3 +1 -0 XEmacs/xemacs/src/number-gmp.h (In the diff below, changes in quantity of whitespace are not shown.) Index: number-gmp.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/number-gmp.h,v retrieving revision 1.2 retrieving revision 1.3 diff -u -b -r1.2 -r1.3 --- number-gmp.h 2004/09/20 19:19:53 1.2 +++ number-gmp.h 2005/02/03 16:14:07 1.3 ＠＠ -152,6 +152,7 ＠＠ #define ratio_set_bigfloat(r,f) mpq_set_f (r, f) #define ratio_set_long_ulong(r,num,den) mpq_set_si (r, num, den) #define ratio_set_ulong_ulong(r,num,den) mpq_set_ui (r, num, den) +/* FIXME: Why does this canonicalize, but the previous 2 don't? */ #define ratio_set_bignum_bignum(r,num,den) do { \ mpz_set (mpq_numref (r), num); \ mpz_set (mpq_denref (r), den); \ 1.14 +33 -7 XEmacs/xemacs/src/number.c (In the diff below, changes in quantity of whitespace are not shown.) Index: number.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/number.c,v retrieving revision 1.13 retrieving revision 1.14 diff -u -b -r1.13 -r1.14 --- number.c 2005/01/24 23:34:04 1.13 +++ number.c 2005/02/03 16:14:07 1.14 ＠＠ -64,12 +64,43 ＠＠ return bignum_hashcode (XBIGNUM_DATA (obj)); } +static void +bignum_convert (const void *object, void **data, Bytecount *size) +{ + CIbyte *bstr = bignum_to_string (*(bignum *)object, 10); + *data = bstr; + *size = strlen(bstr)+1; +} + +static void +bignum_convfree (const void * UNUSED (object), void *data, + Bytecount UNUSED (size)) +{ + xfree (data, void *); +} + +static void * +bignum_deconvert (void *object, void *data, Bytecount UNUSED (size)) +{ + bignum *b = (bignum *) object; + bignum_init(*b); + bignum_set_string(*b, (const char *) data, 10); + return object; +} + +static const struct opaque_convert_functions bignum_opc = { + bignum_convert, + bignum_convfree, + bignum_deconvert +}; + static const struct memory_description bignum_description[] = { - { XD_OPAQUE_PTR, offsetof (Lisp_Bignum, data) }, + { XD_OPAQUE_DATA_CONVERTIBLE, offsetof (Lisp_Bignum, data), + 0, { &bignum_opc }, XD_FLAG_NO_KKCC }, { XD_END } }; -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bignum", bignum, 0, 0, bignum_print, +DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bignum", bignum, 1, 0, bignum_print, 0, bignum_equal, bignum_hash, bignum_description, Lisp_Bignum); ＠＠ -770,13 +801,8 ＠＠ #ifdef HAVE_BIGFLOAT #ifdef HAVE_BIGNUM - /* Uncomment the next two lines and remove the line below them when dumping - bignums becomes possible. */ - /* Vbigfloat_max_prec = make_bignum (0L); bignum_set_ulong (XBIGNUM_DATA (Vbigfloat_max_prec), ULONG_MAX); - */ - Vbigfloat_max_prec = make_int (EMACS_INT_MAX); #else Vbigfloat_max_prec = make_int (EMACS_INT_MAX); #endif 1.27 +4 -4 XEmacs/xemacs/src/objects.c (In the diff below, changes in quantity of whitespace are not shown.) Index: objects.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects.c,v retrieving revision 1.26 retrieving revision 1.27 diff -u -b -r1.26 -r1.27 --- objects.c 2005/01/28 02:58:52 1.26 +++ objects.c 2005/02/03 16:14:07 1.27 ＠＠ -63,7 +63,7 ＠＠ static const struct memory_description color_instance_data_description_1 []= { #ifdef HAVE_TTY - { XD_BLOCK_PTR, tty_console, 1, &tty_color_instance_data_description}, + { XD_BLOCK_PTR, tty_console, 1, { &tty_color_instance_data_description } }, #endif { XD_END } }; ＠＠ -77,7 +77,7 ＠＠ { XD_LISP_OBJECT, offsetof (Lisp_Color_Instance, name)}, { XD_LISP_OBJECT, offsetof (Lisp_Color_Instance, device)}, { XD_UNION, offsetof (Lisp_Color_Instance, data), - XD_INDIRECT (0, 0), &color_instance_data_description }, + XD_INDIRECT (0, 0), { &color_instance_data_description } }, {XD_END} }; ＠＠ -272,7 +272,7 ＠＠ static const struct memory_description font_instance_data_description_1 []= { #ifdef HAVE_TTY - { XD_BLOCK_PTR, tty_console, 1, &tty_font_instance_data_description}, + { XD_BLOCK_PTR, tty_console, 1, { &tty_font_instance_data_description} }, #endif { XD_END } }; ＠＠ -287,7 +287,7 ＠＠ { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, truename)}, { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, device)}, { XD_UNION, offsetof (Lisp_Font_Instance, data), - XD_INDIRECT (0, 0), &font_instance_data_description }, + XD_INDIRECT (0, 0), { &font_instance_data_description } }, { XD_END } }; 1.24 +1 -1 XEmacs/xemacs/src/profile.c (In the diff below, changes in quantity of whitespace are not shown.) Index: profile.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/profile.c,v retrieving revision 1.23 retrieving revision 1.24 diff -u -b -r1.23 -r1.24 --- profile.c 2005/01/26 10:09:20 1.23 +++ profile.c 2005/02/03 16:14:08 1.24 ＠＠ -109,7 +109,7 ＠＠ static const struct memory_description plain_hash_table_description_1[] = { { XD_ELEMCOUNT, offsetof (struct hash_table, size) }, { XD_BLOCK_PTR, offsetof (struct hash_table, harray), XD_INDIRECT (0, 0), - &hentry_description }, + { &hentry_description } }, { XD_END } }; 1.22 +2 -1 XEmacs/xemacs/src/rangetab.c (In the diff below, changes in quantity of whitespace are not shown.) Index: rangetab.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/rangetab.c,v retrieving revision 1.21 retrieving revision 1.22 diff -u -b -r1.21 -r1.22 --- rangetab.c 2005/01/26 10:22:28 1.21 +++ rangetab.c 2005/02/03 16:14:08 1.22 ＠＠ -214,7 +214,8 ＠＠ }; static const struct memory_description range_table_description[] = { - { XD_BLOCK_PTR, offsetof (Lisp_Range_Table, entries), 1, &rted_description }, + { XD_BLOCK_PTR, offsetof (Lisp_Range_Table, entries), 1, + { &rted_description } }, { XD_END } }; 1.95 +6 -6 XEmacs/xemacs/src/redisplay.c (In the diff below, changes in quantity of whitespace are not shown.) Index: redisplay.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/redisplay.c,v retrieving revision 1.94 retrieving revision 1.95 diff -u -b -r1.94 -r1.95 --- redisplay.c 2005/01/26 10:33:41 1.94 +++ redisplay.c 2005/02/03 16:14:08 1.95 ＠＠ -522,7 +522,7 ＠＠ }; static const struct memory_description rune_object_description_1[] = { - { XD_BLOCK_ARRAY, RUNE_DGLYPH, 1, &rune_dglyph_description }, + { XD_BLOCK_ARRAY, RUNE_DGLYPH, 1, { &rune_dglyph_description } }, { XD_END } }; ＠＠ -533,7 +533,7 ＠＠ static const struct memory_description rune_description_1[] = { { XD_INT, offsetof (rune, type) }, { XD_UNION, offsetof (rune, object), - XD_INDIRECT (0, 0), &rune_object_description }, + XD_INDIRECT (0, 0), { &rune_object_description } }, { XD_END } }; ＠＠ -554,7 +554,7 ＠＠ static const struct memory_description display_block_description_1[] = { { XD_BLOCK_PTR, offsetof (display_block, runes), - 1, &rune_dynarr_description }, + 1, { &rune_dynarr_description } }, { XD_END } }; ＠＠ -596,11 +596,11 ＠＠ static const struct memory_description display_line_description_1[] = { { XD_BLOCK_PTR, offsetof (display_line, display_blocks), - 1, &display_block_dynarr_description }, + 1, { &display_block_dynarr_description } }, { XD_BLOCK_PTR, offsetof (display_line, left_glyphs), - 1, &glyph_block_dynarr_description }, + 1, { &glyph_block_dynarr_description } }, { XD_BLOCK_PTR, offsetof (display_line, right_glyphs), - 1, &glyph_block_dynarr_description }, + 1, { &glyph_block_dynarr_description } }, { XD_END } }; 1.39 +4 -4 XEmacs/xemacs/src/specifier.c (In the diff below, changes in quantity of whitespace are not shown.) Index: specifier.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/specifier.c,v retrieving revision 1.38 retrieving revision 1.39 diff -u -b -r1.38 -r1.39 --- specifier.c 2005/01/26 10:22:28 1.38 +++ specifier.c 2005/02/03 16:14:08 1.39 ＠＠ -66,7 +66,7 ＠＠ static const struct memory_description ste_description_1[] = { { XD_LISP_OBJECT, offsetof (specifier_type_entry, symbol) }, { XD_BLOCK_PTR, offsetof (specifier_type_entry, meths), 1, - &specifier_methods_description }, + { &specifier_methods_description } }, { XD_END } }; ＠＠ -397,7 +397,7 ＠＠ const struct memory_description specifier_description[] = { { XD_BLOCK_PTR, offsetof (Lisp_Specifier, methods), 1, - &specifier_methods_description }, + { &specifier_methods_description } }, { XD_LO_LINK, offsetof (Lisp_Specifier, next_specifier) }, { XD_LISP_OBJECT, offsetof (Lisp_Specifier, global_specs) }, { XD_LISP_OBJECT, offsetof (Lisp_Specifier, device_specs) }, ＠＠ -405,11 +405,11 ＠＠ { XD_LISP_OBJECT, offsetof (Lisp_Specifier, window_specs) }, { XD_LISP_OBJECT, offsetof (Lisp_Specifier, buffer_specs) }, { XD_BLOCK_PTR, offsetof (Lisp_Specifier, caching), 1, - &specifier_caching_description }, + { &specifier_caching_description } }, { XD_LISP_OBJECT, offsetof (Lisp_Specifier, magic_parent) }, { XD_LISP_OBJECT, offsetof (Lisp_Specifier, fallback) }, { XD_BLOCK_ARRAY, offsetof (Lisp_Specifier, data), 1, - specifier_extra_description_map }, + { specifier_extra_description_map } }, { XD_END } }; 1.25 +12 -12 XEmacs/xemacs/src/unicode.c (In the diff below, changes in quantity of whitespace are not shown.) Index: unicode.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/unicode.c,v retrieving revision 1.24 retrieving revision 1.25 diff -u -b -r1.24 -r1.25 --- unicode.c 2005/01/24 23:34:13 1.24 +++ unicode.c 2005/02/03 16:14:08 1.25 ＠＠ -224,7 +224,7 ＠＠ }; static const struct memory_description to_unicode_level_1_desc_1[] = { - { XD_BLOCK_PTR, 0, 96, &to_unicode_level_0_desc }, + { XD_BLOCK_PTR, 0, 96, { &to_unicode_level_0_desc } }, { XD_END } }; ＠＠ -233,8 +233,8 ＠＠ }; static const struct memory_description to_unicode_description_1[] = { - { XD_BLOCK_PTR, 1, 96, &to_unicode_level_0_desc }, - { XD_BLOCK_PTR, 2, 96, &to_unicode_level_1_desc }, + { XD_BLOCK_PTR, 1, 96, { &to_unicode_level_0_desc } }, + { XD_BLOCK_PTR, 2, 96, { &to_unicode_level_1_desc } }, { XD_END } }; ＠＠ -246,7 +246,7 ＠＠ /* Used only for to_unicode_blank_2 */ static const struct memory_description to_unicode_level_2_desc_1[] = { - { XD_BLOCK_PTR, 0, 96, &to_unicode_level_1_desc }, + { XD_BLOCK_PTR, 0, 96, { &to_unicode_level_1_desc } }, { XD_END } }; ＠＠ -259,7 +259,7 ＠＠ }; static const struct memory_description from_unicode_level_1_desc_1[] = { - { XD_BLOCK_PTR, 0, 256, &from_unicode_level_0_desc }, + { XD_BLOCK_PTR, 0, 256, { &from_unicode_level_0_desc } }, { XD_END } }; ＠＠ -268,7 +268,7 ＠＠ }; static const struct memory_description from_unicode_level_2_desc_1[] = { - { XD_BLOCK_PTR, 0, 256, &from_unicode_level_1_desc }, + { XD_BLOCK_PTR, 0, 256, { &from_unicode_level_1_desc } }, { XD_END } }; ＠＠ -277,7 +277,7 ＠＠ }; static const struct memory_description from_unicode_level_3_desc_1[] = { - { XD_BLOCK_PTR, 0, 256, &from_unicode_level_2_desc }, + { XD_BLOCK_PTR, 0, 256, { &from_unicode_level_2_desc } }, { XD_END } }; ＠＠ -286,10 +286,10 ＠＠ }; static const struct memory_description from_unicode_description_1[] = { - { XD_BLOCK_PTR, 1, 256, &from_unicode_level_0_desc }, - { XD_BLOCK_PTR, 2, 256, &from_unicode_level_1_desc }, - { XD_BLOCK_PTR, 3, 256, &from_unicode_level_2_desc }, - { XD_BLOCK_PTR, 4, 256, &from_unicode_level_3_desc }, + { XD_BLOCK_PTR, 1, 256, { &from_unicode_level_0_desc } }, + { XD_BLOCK_PTR, 2, 256, { &from_unicode_level_1_desc } }, + { XD_BLOCK_PTR, 3, 256, { &from_unicode_level_2_desc } }, + { XD_BLOCK_PTR, 4, 256, { &from_unicode_level_3_desc } }, { XD_END } }; ＠＠ -301,7 +301,7 ＠＠ /* Used only for from_unicode_blank_4 */ static const struct memory_description from_unicode_level_4_desc_1[] = { - { XD_BLOCK_PTR, 0, 256, &from_unicode_level_3_desc }, + { XD_BLOCK_PTR, 0, 256, { &from_unicode_level_3_desc } }, { XD_END } }; 1.83 +6 -6 XEmacs/xemacs/src/window.c (In the diff below, changes in quantity of whitespace are not shown.) Index: window.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/window.c,v retrieving revision 1.82 retrieving revision 1.83 diff -u -b -r1.82 -r1.83 --- window.c 2005/01/24 23:34:13 1.82 +++ window.c 2005/02/03 16:14:08 1.83 ＠＠ -171,7 +171,7 ＠＠ static const struct memory_description face_cachel_description_1[] = { { XD_BLOCK_PTR, offsetof (face_cachel, merged_faces), - 1, &int_dynarr_description }, + 1, { &int_dynarr_description } }, { XD_LISP_OBJECT, offsetof (face_cachel, face) }, { XD_LISP_OBJECT, offsetof (face_cachel, foreground) }, { XD_LISP_OBJECT, offsetof (face_cachel, background) }, ＠＠ -242,11 +242,11 ＠＠ #include "winslots.h" { XD_BLOCK_PTR, offsetof (struct window, face_cachels), - 1, &face_cachel_dynarr_description }, + 1, { &face_cachel_dynarr_description } }, { XD_BLOCK_PTR, offsetof (struct window, glyph_cachels), - 1, &glyph_cachel_dynarr_description }, + 1, { &glyph_cachel_dynarr_description } }, { XD_BLOCK_PTR, offsetof (struct window, line_start_cache), - 1, &line_start_cache_dynarr_description }, + 1, { &line_start_cache_dynarr_description } }, { XD_END } }; ＠＠ -423,9 +423,9 ＠＠ { XD_LISP_OBJECT, offsetof (struct window_mirror, vchild) }, { XD_BLOCK_PTR, offsetof (struct window_mirror, current_display_lines), - 1, &display_line_dynarr_description }, + 1, { &display_line_dynarr_description } }, { XD_BLOCK_PTR, offsetof (struct window_mirror, desired_display_lines), - 1, &display_line_dynarr_description }, + 1, { &display_line_dynarr_description } }, { XD_LISP_OBJECT, offsetof (struct window_mirror, buffer) },

1 participants
0 comments

CVS update: MODIFIED: packages ... 20 years, 2 months

CVS Monitor

User: ben Date: 05/02/03 09:39:15 Modified: packages ChangeLog XEmacs.rules Log: Fix autoload problems in package smokescreen XEmacs.rules: Rearrange things so that we forcibly disable all interactions with any external package references compiled into XEmacs, and turn off all autoloads at startup, then manually set up a clean load-path pointing to what we need, and load the autoloads. This ensures that we *really* have no dependency on any external packages and that we always have a known environment in which we work. #### A few places still seem to depend on having external packages. It should be easy to remove them but I don't understand the code in question (for building package-info, setup-info). Revision Changes Path 1.490 +24 -0 XEmacs/packages/ChangeLog (In the diff below, changes in quantity of whitespace are not shown.) Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/ChangeLog,v retrieving revision 1.489 retrieving revision 1.490 diff -u -b -r1.489 -r1.490 --- ChangeLog 2005/01/31 20:19:22 1.489 +++ ChangeLog 2005/02/03 08:39:14 1.490 ＠＠ -1,3 +1,27 ＠＠ +2005-02-03 Ben Wing <ben(a)xemacs.org> + + * XEmacs.rules: + * XEmacs.rules (XEMACS_BATCH_PREPARE_FOR_TEXINFO): + * XEmacs.rules (FORMAT_INFO_USING_XEMACS_ARGS): + * XEmacs.rules (FORMAT_INFO_USING_XEMACS): + * XEmacs.rules (FORMAT_MULE_INFO_USING_XEMACS): + * XEmacs.rules (BOOT_XEMACS): + * XEmacs.rules (elcclean): + * XEmacs.rules ($(AUTOLOAD_PATH)/auto-autoloads.el): + * XEmacs.rules ($(AUTOLOAD_PATH)/custom-defines.el): + * XEmacs.rules ($(AUTOLOAD_PATH)/custom-load.el): + * XEmacs.rules (package-info): + * XEmacs.rules (setup-info): + Rearrange things so that we forcibly disable all interactions with + any external package references compiled into XEmacs, and turn off + all autoloads at startup, then manually set up a clean load-path + pointing to what we need, and load the autoloads. This ensures that + we *really* have no dependency on any external packages and that we + always have a known environment in which we work. #### A few places + still seem to depend on having external packages. It should be easy + to remove them but I don't understand the code in question (for + building package-info, setup-info). + 2005-01-31 Norbert Koch <viteno(a)xemacs.org> * Packages released: edit-utils. 1.55 +33 -16 XEmacs/packages/XEmacs.rules (In the diff below, changes in quantity of whitespace are not shown.) Index: XEmacs.rules =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/XEmacs.rules,v retrieving revision 1.54 retrieving revision 1.55 diff -u -b -r1.54 -r1.55 --- XEmacs.rules 2004/12/24 11:49:26 1.54 +++ XEmacs.rules 2005/02/03 08:39:15 1.55 ＠＠ -1,6 +1,6 ＠＠ # Common Makefile material for package Makefiles # Copyright (C) 1997 Free Software Foundation Inc. -# Copyright (C) 2002, 2003 Ben Wing. +# Copyright (C) 2002, 2003, 2005 Ben Wing. # This file is part of XEmacs. ＠＠ -154,6 +154,22 ＠＠ endif endif +# We should strive to use XEMACS_BATCH_CLEAN as much as possible, so we have +# no possible contamination from outside packages. We should rewrite the +# others to load the appropriate autoloads from our own built package tree. + +ifeq ($(BUILD_WITHOUT_MULE),t) +LISP_DIRECTORIES= (list lisp-directory) +else +LISP_DIRECTORIES= (list (expand-file-name "mule" lisp-directory) lisp-directory) +endif +XEMACS_BATCH_CLEAN = $(XEMACS) -no-autoloads $(BATCH) -eval '(setq load-path $(LISP_DIRECTORIES))' +# The following works more or less the same and with less fuss, but only in +# 21.5 and above +# XEMACS_BATCH_CLEAN = $(XEMACS) -no-autoloads $(BATCH) -no-packages +XEMACS_BATCH_DIRTY = $(XEMACS) $(BATCH) +LOAD_AUTOLOADS= -eval '(packages-load-package-auto-autoloads load-path)' + ##################################### # Handle docs # ##################################### ＠＠ -259,18 +275,19 ＠＠ html: $(HTML_DEP) -FORMAT_INFO_USING_XEMACS_NO_SAVE_ARGS = -eval '(setq load-path (append (list "$(XEMACS_PACKAGES_BASE)/xemacs-packages/texinfo" "$(XEMACS_PACKAGES_BASE)/xemacs-packages/text-modes" "$(XEMACS_PACKAGES_BASE)/xemacs-packages/xemacs-base") load-path))' -l informat -l texinfmt -f texinfo-format-buffer +XEMACS_BATCH_PREPARE_FOR_TEXINFO = $(XEMACS_BATCH_CLEAN) -eval '(setq load-path (append (list "$(XEMACS_PACKAGES_BASE)/xemacs-packages/texinfo" "$(XEMACS_PACKAGES_BASE)/xemacs-packages/text-modes" "$(XEMACS_PACKAGES_BASE)/xemacs-packages/xemacs-base") load-path))' $(LOAD_AUTOLOADS) -FORMAT_INFO_USING_XEMACS_ARGS = $(FORMAT_INFO_USING_XEMACS_NO_SAVE_ARGS) -f save-buffer +FORMAT_INFO_USING_XEMACS_ARGS = -l informat -l texinfmt -f texinfo-format-buffer FORMAT_INFO_USING_XEMACS = \ - $(XEMACS) $(BATCH) -insert $< $(FORMAT_INFO_USING_XEMACS_ARGS) + $(XEMACS_BATCH_PREPARE_FOR_TEXINFO) -insert $< \ + $(FORMAT_INFO_USING_XEMACS_ARGS) -f save-buffer FORMAT_MULE_INFO_USING_XEMACS = \ - $(XEMACS) $(BATCH) -insert $< \ + $(XEMACS_BATCH_PREPARE_FOR_TEXINFO) -insert $< \ -eval '(unless (featurep (quote mule)) (kill-emacs 0))' \ -eval '(cd "$(<D)")' \ - $(FORMAT_INFO_USING_XEMACS_NO_SAVE_ARGS) \ + $(FORMAT_INFO_USING_XEMACS_ARGS) \ -eval '(setq file-coding-system (quote iso-2022-7))' \ -eval '(save-buffer 0)' ＠＠ -364,7 +381,7 ＠＠ endif # Behaves like an XEmacs with the required packages set up -BOOT_XEMACS= $(XEMACS) -no-autoloads $(BATCH) -l $(PACKAGE_COMPILE) -- $(REQUIRES) -- $(PRELOADS) +BOOT_XEMACS= $(XEMACS_BATCH_CLEAN) -l $(PACKAGE_COMPILE) -- $(REQUIRES) -- $(PRELOADS) %.elc: %.el $(BOOT_XEMACS) -f batch-byte-compile $< ＠＠ -433,7 +450,7 ＠＠ # This is less of an issue now that we ignore out-of-date .elc files. --ben elcclean: - $(XEMACS) $(BATCH) -l $(PACKAGE_CLEAN) + $(XEMACS_BATCH_CLEAN) -l $(PACKAGE_CLEAN) GENERATED_ELC_DEPENDENCIES = $(ELCS:.elc=.el) $(ELCS_1:.elc=.el) \ $(AUTOLOAD_PATH)/_pkg.el ＠＠ -447,14 +464,14 ＠＠ ifeq ($(XEMACS_21_5),t) $(AUTOLOAD_PATH)/auto-autoloads.el :: $(GENERATED_ELC_DEPENDENCIES) - $(XEMACS) $(BATCH) -no-autoloads \ + $(XEMACS_BATCH_CLEAN) $(LOAD_AUTOLOADS) \ -l autoload -f batch-update-directory-autoloads \ $(PACKAGE) $(AUTOLOAD_PATH) # The equivalent of `touch' is done automatically ＠rm -f $(AUTOLOAD_PATH)/auto-autoloads.el~ $(AUTOLOAD_PATH)/custom-defines.el : $(GENERATED_ELC_DEPENDENCIES) - $(XEMACS) $(BATCH) -no-autoloads \ + $(XEMACS_BATCH_CLEAN) $(LOAD_AUTOLOADS) \ -l autoload -f batch-update-directory-custom-defines \ $(PACKAGE) $(AUTOLOAD_PATH) ＠rm -f $(AUTOLOAD_PATH)/custom-defines.el~ ＠＠ -465,7 +482,7 ＠＠ \"$(AUTOLOAD_PATH)/auto-autoloads.el\") $(AUTOLOAD_PATH)/auto-autoloads.el :: $(GENERATED_ELC_DEPENDENCIES) - $(XEMACS) $(BATCH) -no-autoloads \ + $(XEMACS_BATCH_CLEAN) $(LOAD_AUTOLOADS) \ -eval "$(AUTOLOAD_PACKAGE_NAME)" \ -eval "$(AUTOLOAD_FILE)" \ -l autoload -f batch-update-autoloads $^ ＠＠ -474,7 +491,7 ＠＠ endif $(AUTOLOAD_PATH)/custom-load.el : $(GENERATED_ELC_DEPENDENCIES) - $(XEMACS) $(BATCH) -no-autoloads -l cus-dep \ + $(XEMACS_BATCH_CLEAN) $(LOAD_AUTOLOADS) -l cus-dep \ -f Custom-make-dependencies $(AUTOLOAD_PATH) ＠touch $(AUTOLOAD_PATH)/custom-load.el ＠rm -f $(AUTOLOAD_PATH)/custom-load.el~ ＠＠ -494,12 +511,12 ＠＠ # Make the $(pkg_tar).gz first, then the $(pkg_tar).bz2 package-info : package-info.in Makefile $(AUTOLOAD_PATH)/_pkg.el \ $(pkg_tar).gz $(pkg_tar).bz2 - $(XEMACS) $(BATCH) \ + $(XEMACS_BATCH_DIRTY) \ # #### See if we can't CLEAN this up -l package-info.elc -f batch-update-package-info \ '$(VERSION)' $(PKG_TAR_GZ) \ '$(REQUIRES)' \ '$(AUTHOR_VERSION)' '$(MAINTAINER)' '$(CATEGORY)' - $(XEMACS) $(BATCH) \ + $(XEMACS_BATCH_DIRTY) \ # #### See if we can't CLEAN this up -l ../../hack-package-index.el -f batch-hack-package-index \ $(PACKAGE) package-info $(PACKAGE_INFO) $(CATEGORY) ＠＠ -557,8 +574,8 ＠＠＠echo ")" >> $(AUTOLOAD_PATH)/_pkg.el endif -setup-info: - $(XEMACS) $(BATCH) -l $(PACKAGE_NET_PACKAGES) \ +setup-info: # #### See if we can't CLEAN this up + $(XEMACS_BATCH_DIRTY) -l $(PACKAGE_NET_PACKAGES) \ -l $(PACKAGE_INFO) \ -f package-net-packages-batch-convert-index-to-ini $(PACKAGE_STAGING) $(CATEGORY)

1 participants
0 comments

CVS update: MODIFIED: lisp ... 20 years, 2 months

CVS Monitor

User: ben Date: 05/02/03 08:30:23 Modified: xemacs/lisp ChangeLog regexp-opt.el Log: Update regexp-opt regexp-opt.el: Update to latest version in package tree. Revision Changes Path 1.626 +8 -0 XEmacs/xemacs/lisp/ChangeLog (In the diff below, changes in quantity of whitespace are not shown.) Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/ChangeLog,v retrieving revision 1.625 retrieving revision 1.626 diff -u -b -r1.625 -r1.626 --- ChangeLog 2005/02/03 07:15:56 1.625 +++ ChangeLog 2005/02/03 07:30:21 1.626 ＠＠ -1,5 +1,13 ＠＠ 2005-02-03 Ben Wing <ben(a)xemacs.org> + * regexp-opt.el: + * regexp-opt.el (regexp-opt): + * regexp-opt.el (regexp-opt-not-groupie*-re): New. + * regexp-opt.el (regexp-opt-group): + Update to latest version in package tree. + +2005-02-03 Ben Wing <ben(a)xemacs.org> + * paragraphs.el: * paragraphs.el (paragraphs): New. * paragraphs.el (use-hard-newlines): Removed. 1.2 +58 -58 XEmacs/xemacs/lisp/regexp-opt.el (In the diff below, changes in quantity of whitespace are not shown.) Index: regexp-opt.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/regexp-opt.el,v retrieving revision 1.1 retrieving revision 1.2 diff -u -b -r1.1 -r1.2 --- regexp-opt.el 2005/02/03 07:11:21 1.1 +++ regexp-opt.el 2005/02/03 07:30:22 1.2 ＠＠ -6,9 +6,6 ＠＠ ;; Maintainer: FSF ;; Keywords: strings, regexps, extensions -;; Modified by Karl M. Hegbloom Sep. 1997 to support the new regexp syntax -;; with shy groups. (benchmarks pending) - ;; This file is part of XEmacs. ;; XEmacs is free software; you can redistribute it and/or modify ＠＠ -26,9 +23,15 ＠＠ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. +;;; Synched up with: GNU Emacs 21.3 + paren-in-char-set fix from CVS +;;; revision 1.25. Some implementation differences in +;;; regexp-opt-group and regexp-opt-charset but the APIs +;;; are compatible and should return compatible (if not +;;; exactly the same) regexps. + ;;; Commentary: -;; The "opt" in "regexp-opt" stands for "optim\$al\\|i\\(se\\|ze\$\\)". +;; The "opt" in "regexp-opt" stands for "optim\$?:al\\|i\\(?:se\\|ze\$\\)". ;; ;; This package generates a regexp from a given list of strings (which matches ;; one of those strings) so that the regexp generated by: ＠＠ -47,19 +50,7 ＠＠ ;; "save-current-buffer" "save-match-data" ;; "catch" "throw" "unwind-protect" "condition-case"))) ;; (concat "(" (regexp-opt strings t) "\\>")) -;; -;; => "(\$?:c\\(?:atch\\|ond\\(?:ition-case\$?\\)\\|if\\|let\\*?\\|prog[12n]\\|save-\$?:current-buffer\\|excursion\\|match-data\\|restriction\\|window-excursion\$\\|throw\\|un\$?:less\\|wind-protect\$\\|wh\$?:en\\|ile\$\\)\\>" -;; -;; -;; (let ((strings '("cond" "if" "when" "unless" "while" -;; "let" "let*" "progn" "prog1" "prog2" -;; "save-restriction" "save-excursion" "save-window-excursion" -;; "save-current-buffer" "save-match-data" -;; "catch" "throw" "unwind-protect" "condition-case"))) -;; (concat "(" (regexp-opt strings t t) "\\>")) -;; ^ -;; => "(\$c\\(atch\\|ond\\(ition-case\$?\\)\\|if\\|let\\*?\\|prog[12n]\\|save-\$current-buffer\\|excursion\\|match-data\\|restriction\\|window-excursion\$\\|throw\\|un\$less\\|wind-protect\$\\|wh\$en\\|ile\$\\)\\>" -;; +;; => "(\$c\\(?:atch\\|ond\\(?:ition-case\$?\\)\\|if\\|let\\*?\\|prog[12n]\\|save-\$?:current-buffer\\|excursion\\|match-data\\|restriction\\|window-excursion\$\\|throw\\|un\$?:less\\|wind-protect\$\\|wh\$?:en\\|ile\$\\)\\>" ;; ;; Searching using the above example `regexp-opt' regexp takes approximately ;; two-thirds of the time taken using the equivalent `mapconcat' regexp. ＠＠ -88,30 +79,29 ＠＠ ;; your code for such changes to have effect in your code. ;; Originally written for font-lock.el, from an idea from Stig's hl319.el, with -;; thanks for ideas also to Michael Ernst, Bob Glickstein and Dan Nicolaescu. -;; Please don't tell me that it doesn't produce optimal regexps; I know that -;; already. For example, the above explanation for the meaning of "opt" would -;; be more efficient as "optim\$al\\|i[sz]e\$", but this requires complex -;; forward looking. But (ideas or) code to improve things (are) is welcome. +;; thanks for ideas also to Michael Ernst, Bob Glickstein, Dan Nicolaescu and +;; Stefan Monnier. +;; No doubt `regexp-opt' doesn't always produce optimal regexps, so code, ideas +;; or any other information to improve things are welcome. +;; +;; One possible improvement would be to compile '("aa" "ab" "ba" "bb") +;; into "[ab][ab]" rather than "a[ab]\\|b[ab]". I'm not sure it's worth +;; it but if someone knows how to do it without going through too many +;; contortions, I'm all ears. ;;; Code: ;;;###autoload -(defun regexp-opt (strings &optional paren non-shy) +(defun regexp-opt (strings &optional paren) "Return a regexp to match a string in STRINGS. Each string should be unique in STRINGS and should not contain any regexps, quoted or not. If optional PAREN is non-nil, ensure that the returned regexp -is enclosed by at least one regexp match grouping construct. If optional -NON-SHY is non nil, the inner groupings will use \"\\\$ \\\$\" grouping, -rather than the default \"\\\$?: \\\$\" 'shy', or non-match-capturing groups. +is enclosed by at least one regexp grouping construct. The returned regexp is typically more efficient than the equivalent regexp: - (let ((open-paren (if PAREN \"\\\$\" \"\")) (close-paren (if PAREN \"\\\$\" \"\"))) - (concat open-paren (mapconcat 'regexp-quote STRINGS \"\\\\|\") close-paren)) + (let ((open (if PAREN \"\\\$\" \"\")) (close (if PAREN \"\\\$\" \"\"))) + (concat open (mapconcat 'regexp-quote STRINGS \"\\\\|\") close)) -but typically contains more regexp grouping constructs. -Use `regexp-opt-depth' to count them. - If PAREN is `words', then the resulting regexp is additionally surrounded by \\=\\< and \\>." (save-match-data ＠＠ -119,56 +109,66 ＠＠ (let* ((max-lisp-eval-depth (* 1024 1024)) (completion-ignore-case nil) (words (eq paren 'words)) + (open (cond ((stringp paren) paren) (paren "\$"))) (sorted-strings (sort (copy-sequence strings) 'string-lessp)) - (re (regexp-opt-group sorted-strings paren nil non-shy))) + (re (regexp-opt-group sorted-strings open))) (if words (concat "\\<" re "\\>") re)))) +(defconst regexp-opt-not-groupie*-re + (let* ((harmless-ch "[^\\\\[]") + (esc-pair-not-lp "\\\\[^(]") + (class-harmless-ch "[^][]") + (class-lb-harmless "[^]:]") + (class-lb-colon-maybe-charclass ":\\([a-z]+:]\$?") + (class-lb (concat "\\[\$" class-lb-harmless + "\\|" class-lb-colon-maybe-charclass "\$")) + (class + (concat "\\[^?]?" + "\$" class-harmless-ch + "\\|" class-lb "\$*" + "\\[?]")) ; special handling for bare [ at end of re + (shy-lp "\\\$\\?:")) + (concat "\\(" harmless-ch "\\|" esc-pair-not-lp + "\\|" class "\\|" shy-lp "\$*")) + "Matches any part of a regular expression EXCEPT for non-shy \"\\\$\"s") + ;;;###autoload -(defun regexp-opt-depth (regexp &optional count-shy-groups-too) +(defun regexp-opt-depth (regexp) "Return the depth of REGEXP. -This means the number of regexp grouping constructs (parenthesised -expressions) in REGEXP, not counting the \"\\\\(?: \\\$\" -non-match-capturing groups unless COUNT-SHY-GROUPS-TOO is non-nil. -See `regexp-opt'." +This means the number of regexp grouping constructs (parenthesised expressions) +in REGEXP." (save-match-data ;; Hack to signal an error if REGEXP does not have balanced parentheses. (string-match regexp "") ;; Count the number of open parentheses in REGEXP. - (let ((max (1- (length regexp))) - (count 0) start) - (while (string-match "\\\$" regexp start) - (setq start (match-end 0)) - (when (or count-shy-groups-too - (not (string= (substring regexp start (min (+ start 2) max)) "?:"))) - (setq count (1+ count)))) + (let ((count 0) start) + (while + (progn + (string-match regexp-opt-not-groupie*-re regexp start) + (setq start ( + (match-end 0) 2)) ; +2 for "\\(" after match-end. + (<= start (length regexp))) + (setq count (1+ count))) count))) ;;; Workhorse functions. (eval-when-compile (require 'cl)) - -(unless (fboundp 'make-bool-vector) - (defalias 'make-bool-vector 'make-vector)) -(defun regexp-opt-group (strings &optional paren lax non-shy) +(defun regexp-opt-group (strings &optional paren lax) "Return a regexp to match a string in STRINGS. If PAREN non-nil, output regexp parentheses around returned regexp. If LAX non-nil, don't output parentheses if it doesn't require them. -If NON-SHY non-nil, don't use \\(?: \$ shy groups, use match capturing ones. Merges keywords to avoid backtracking in Emacs' regexp matcher. -The basic idea is to find the shortest common prefix, remove it +The basic idea is to find the shortest common prefix or suffix, remove it and recurse. If there is no prefix, we divide the list into two so that $at least) one half will have at least a one-character common prefix. Also we delay the addition of grouping parenthesis as long as possible until we're sure we need them, and try to remove one-character sequences so we can use character sets rather than grouping parenthesis." - (let* ((open-group (cond - ((and paren non-shy) "\\(") - (paren "\\(?:") - (t ""))) + (let* ((open-group (cond ((stringp paren) paren) (paren "\\(?:") (t ""))) (close-group (if paren "\$" "")) (open-charset (if lax "" open-group)) (close-charset (if lax "" close-group))) ＠＠ -187,7 +187,7 ＠＠ ;; If there is an empty string, remove it and recurse on the rest. ((= (length (car strings)) 0) (concat open-charset - (regexp-opt-group (cdr strings) t t non-shy) "?" + (regexp-opt-group (cdr strings) t t) "?" close-charset)) ;; ;; If all are one-character strings, just return a character set. ＠＠ -208,7 +208,7 ＠＠ (let* ((length (length prefix)) (suffixes (mapcar (lambda (s) (substring s length)) strings))) (concat open-group - (regexp-quote prefix) (regexp-opt-group suffixes t t non-shy) + (regexp-quote prefix) (regexp-opt-group suffixes t t) close-group))) ;; ;; If there are several one-character strings, remove them and recurse ＠＠ -217,7 +217,7 ＠＠ (let ((rest (let ((completion-regexp-list '("^..+$"))) (all-completions "" (mapcar 'list strings))))) (concat open-group - (regexp-opt-group rest nil nil non-shy) "\\|" (regexp-opt-charset letters) + (regexp-opt-group rest) "\\|" (regexp-opt-charset letters) close-group))) ;; ;; Otherwise, divide the list into those that start with a particular ＠＠ -227,7 +227,7 ＠＠ (half1 (all-completions char (mapcar 'list strings))) (half2 (nthcdr (length half1) strings))) (concat open-group - (regexp-opt-group half1 nil nil non-shy) "\\|" (regexp-opt-group half2 nil nil non-shy) + (regexp-opt-group half1) "\\|" (regexp-opt-group half2) close-group))))))))) (defun regexp-opt-charset (chars)

1 participants
0 comments

CVS update: MODIFIED: lisp ... 20 years, 2 months

CVS Monitor

User: ben Date: 05/02/03 08:15:57 Modified: xemacs/lisp ChangeLog paragraphs.el Log: behavior ws #5: paragraphs.el sync to 21.3 paragraphs.el: Sync to 21.3. Depends on easy-mmode in core. Revision Changes Path 1.625 +18 -19 XEmacs/xemacs/lisp/ChangeLog (In the diff below, changes in quantity of whitespace are not shown.) Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/ChangeLog,v retrieving revision 1.624 retrieving revision 1.625 diff -u -b -r1.624 -r1.625 --- ChangeLog 2005/02/03 07:11:19 1.624 +++ ChangeLog 2005/02/03 07:15:56 1.625 ＠＠ -1,3 +1,21 ＠＠ +2005-02-03 Ben Wing <ben(a)xemacs.org> + + * paragraphs.el: + * paragraphs.el (paragraphs): New. + * paragraphs.el (use-hard-newlines): Removed. + * paragraphs.el (paragraph-start): + * paragraphs.el (paragraph-separate): + * paragraphs.el (sentence-end-double-space): New. + * paragraphs.el (sentence-end-without-period): New. + * paragraphs.el (sentence-end): + * paragraphs.el (forward-paragraph): + * paragraphs.el (backward-paragraph): + * paragraphs.el (mark-paragraph): + * paragraphs.el (forward-sentence): + * paragraphs.el (mark-end-of-sentence): + * paragraphs.el (transpose-sentences): + Sync to 21.3. Depends on easy-mmode in core. + 2005-02-02 Ben Wing <ben(a)xemacs.org> * easy-mmode.el, regexp-opt.el: ＠＠ -249,25 +267,6 ＠＠ * custom.el (custom-theme-reset-variables): * custom.el (custom-reset-variables): Sync with FSF 21.3. - -2004-11-09 Ben Wing <ben(a)xemacs.org> - - * paragraphs.el: - * paragraphs.el (paragraphs): New. - * paragraphs.el (use-hard-newlines): Removed. - * paragraphs.el (paragraph-start): - * paragraphs.el (paragraph-separate): - * paragraphs.el (sentence-end-double-space): New. - * paragraphs.el (sentence-end-without-period): New. - * paragraphs.el (sentence-end): - * paragraphs.el (forward-paragraph): - * paragraphs.el (backward-paragraph): - * paragraphs.el (mark-paragraph): - * paragraphs.el (forward-sentence): - * paragraphs.el (mark-end-of-sentence): - * paragraphs.el (transpose-sentences): - Sync to 21.3. Depends on easy-mmode in core. - 2005-01-31 Ben Wing <ben(a)xemacs.org> 1.8 +201 -134 XEmacs/xemacs/lisp/paragraphs.el (In the diff below, changes in quantity of whitespace are not shown.) Index: paragraphs.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/paragraphs.el,v retrieving revision 1.7 retrieving revision 1.8 diff -u -b -r1.7 -r1.8 --- paragraphs.el 2001/12/05 04:09:25 1.7 +++ paragraphs.el 2005/02/03 07:15:56 1.8 ＠＠ -1,6 +1,6 ＠＠ -;;; paragraphs.el --- paragraph and sentence parsing. +;;; paragraphs.el --- paragraph and sentence parsing -;; Copyright (C) 1985, 86, 87, 91, 94, 95, 97, 2001 +;; Copyright (C) 1985, 86, 87, 91, 94, 95, 96, 1997, 1999, 2000, 2001 ;; Free Software Foundation, Inc. ;; Maintainer: FSF ＠＠ -23,7 +23,7 ＠＠ ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; 02111-1307, USA. -;;; Synched up with: FSF 19.34. +;;; Synched up with: FSF 21.3. ;;; Commentary: ＠＠ -37,19 +37,11 ＠＠ ;;; Code: -(defvar use-hard-newlines nil - "Non-nil means to distinguish hard and soft newlines. -When this is non-nil, the functions `newline' and `open-line' add the -text-property `hard' to newlines that they insert. Also, a line is -only considered as a candidate to match `paragraph-start' or -`paragraph-separate' if it follows a hard newline. Newlines not -marked hard are called \"soft\", and are always internal to -paragraphs. The fill functions always insert soft newlines. - -Each buffer has its own value of this variable.") -(make-variable-buffer-local 'use-hard-newlines) +(defgroup paragraphs nil + "Paragraph and sentence parsing." + :group 'editing) -(defun use-hard-newlines (&optional arg insert) +(define-minor-mode use-hard-newlines "Minor mode to distinguish hard and soft newlines. When active, the functions `newline' and `open-line' add the text-property `hard' to newlines that they insert, and a line is ＠＠ -58,7 +50,7 ＠＠ Prefix argument says to turn mode on if positive, off if negative. When the mode is turned on, if there are newlines in the buffer but no hard -newlines, ask the user whether to mark as hard any newlines preceding a +newlines, ask the user whether to mark as hard any newlines preceeding a `paragraph-start' line. From a program, second arg INSERT specifies whether to do this; it can be `never' to change nothing, t or `always' to force marking, `guess' to try to do the right thing with no questions, nil ＠＠ -66,17 +58,14 ＠＠ Newlines not marked hard are called \"soft\", and are always internal to paragraphs. The fill functions insert and delete only soft newlines." - (interactive (list current-prefix-arg nil)) - (if (or (<= (prefix-numeric-value arg) 0) - (and use-hard-newlines (null arg))) - ;; Turn mode off - (setq use-hard-newlines nil) + :group 'paragraphs + :extra-args (insert) + (when use-hard-newlines ;; Turn mode on ;; Intuit hard newlines -- ;; mark as hard any newlines preceding a paragraph-start line. (if (or (eq insert t) (eq insert 'always) (and (not (eq 'never insert)) - (not use-hard-newlines) (not (text-property-any (point-min) (point-max) 'hard t)) (save-excursion (goto-char (point-min)) ＠＠ -88,19 +77,16 ＠＠ (while (search-forward "\n" nil t) (let ((pos (point))) (move-to-left-margin) - (if (looking-at paragraph-start) - (progn - (set-hard-newline-properties (1- pos) pos) + (when (looking-at paragraph-start) + (set-hard-newline-properties (1- pos) pos)) ;; If paragraph-separate, newline after it is hard too. - (if (looking-at paragraph-separate) - (progn + (when (looking-at paragraph-separate) + (set-hard-newline-properties (1- pos) pos) (end-of-line) - (if (not (eobp)) - (set-hard-newline-properties - (point) (1+ (point)))))))))))) - (setq use-hard-newlines t))) + (unless (eobp) + (set-hard-newline-properties (point) (1+ (point))))))))))) -(defconst paragraph-start "[ \t\n\f]" "\ +(defcustom paragraph-start "\f\\|[ \t]*$" "\ *Regexp for beginning of a line that starts OR separates paragraphs. This regexp should match lines that separate paragraphs and should also match lines that start a paragraph ＠＠ -115,7 +101,9 ＠＠ lines that start paragraphs from lines that separate them. If the variable `use-hard-newlines' is non-nil, then only lines following a -hard newline are considered to match.") +hard newline are considered to match." + :group 'paragraphs + :type 'regexp) ;; paragraph-start requires a hard newline, but paragraph-separate does not: ;; It is assumed that paragraph-separate is distinctive enough to be believed ＠＠ -123,8 +111,8 ＠＠ ;; something very minimal, even including "." (which makes every hard newline ;; start a new paragraph). -(defconst paragraph-separate "[ \t\f]*$" "\ -*Regexp for beginning of a line that separates paragraphs. +(defcustom paragraph-separate "[ \t\f]*$" + "*Regexp for beginning of a line that separates paragraphs. If you change this, you may have to change `paragraph-start' also. A line matching this is not part of any paragraph. ＠＠ -132,34 +120,78 ＠＠ This is matched against the text at the left margin, which is not necessarily the beginning of the line, so it should not use \"^\" as an anchor. This ensures that the paragraph functions will work equally within a region of -text indented by a margin setting.") - -(defconst sentence-end "[.?!][]\"')}]*\$$\\| $\\|\t\\| \$[ \t\n]*" "\ -*Regexp describing the end of a sentence. +text indented by a margin setting." + :group 'paragraphs + :type 'regexp) + +(defcustom sentence-end-double-space t + "*Non-nil means a single space does not end a sentence. +This is relevant for filling. See also `sentence-end-without-period' +and `colon-double-space'. + +This variable applies only to filling, not motion commands. To +change the behavior of motion commands, see `sentence-end'. + +If you change this, you should also change `sentence-end'. See Info +node `Sentences'." + :type 'boolean + :group 'fill) + +(defcustom sentence-end-without-period nil + "*Non-nil means a sentence will end without a period. +For example, a sentence in Thai text ends with double space but +without a period." + :type 'boolean + :group 'fill) + +(defcustom sentence-end + (purecopy + ;; This is a bit stupid since it's not auto-updated when the + ;; other variables are changes, but it's still useful info. + (concat (if sentence-end-without-period "\\w \\|") + "[.?!$B!#!%!)!*$A!##.#?#!$(0!$!%!)!*$(G!$!%!)!*(B][]\"')}]*" + (if sentence-end-double-space + "\$$\\| $\\|\t\\| \$" "\$$\\|[\t ]\$") + "[ \t\n]*")) + "*Regexp describing the end of a sentence. +The value includes the whitespace following the sentence. All paragraph boundaries also end sentences, regardless. -In order to be recognized as the end of a sentence, the ending period, -question mark, or exclamation point must be followed by two spaces, -unless it's inside some sort of quotes or parenthesis.") - -(defconst page-delimiter "^\014" "\ -*Regexp describing line-beginnings that separate pages.") - -(defvar paragraph-ignore-fill-prefix nil "\ -Non-nil means the paragraph commands are not affected by `fill-prefix'. -This is desirable in modes where blank lines are the paragraph delimiters.") +The default value specifies that in order to be recognized as the end +of a sentence, the ending period, question mark, or exclamation point +must be followed by two spaces, unless it's inside some sort of quotes +or parenthesis. + +See also the variable `sentence-end-double-space', the variable +`sentence-end-without-period' and Info node `Sentences'." + :group 'paragraphs + :type 'regexp) + +(defcustom page-delimiter "^\014" + "*Regexp describing line-beginnings that separate pages." + :group 'paragraphs + :type 'regexp) + +(defcustom paragraph-ignore-fill-prefix nil + "*Non-nil means the paragraph commands are not affected by `fill-prefix'. +This is desirable in modes where blank lines are the paragraph delimiters." + :group 'paragraphs + :type 'boolean) (defun forward-paragraph (&optional arg) "Move forward to end of paragraph. -With arg N, do it N times; negative arg -N means move backward N paragraphs. +With argument ARG, do it ARG times; +a negative argument ARG = -N means move backward N paragraphs. A line which `paragraph-start' matches either separates paragraphs \(if `paragraph-separate' matches it also) or is the first line of a paragraph. A paragraph end is the beginning of a line which is not part of the paragraph -to which the end of the previous line belongs, or the end of the buffer." +to which the end of the previous line belongs, or the end of the buffer. +Returns the count of paragraphs left to move." (interactive "_p") ; XEmacs (or arg (setq arg 1)) - (let* ((fill-prefix-regexp + (let* ((opoint (point)) + (fill-prefix-regexp (and fill-prefix (not (equal fill-prefix "")) (not paragraph-ignore-fill-prefix) (regexp-quote fill-prefix))) ＠＠ -168,70 +200,74 ＠＠ ;; starting at the left-margin. This allows paragraph commands to ;; work normally with indented text. ;; This hack will not find problem cases like "whatever\\|^something". - (paragraph-start (if (and (not (equal "" paragraph-start)) + (parstart (if (and (not (equal "" paragraph-start)) (equal ?^ (aref paragraph-start 0))) (substring paragraph-start 1) paragraph-start)) - (paragraph-separate (if (and (not (equal "" paragraph-start)) + (parsep (if (and (not (equal "" paragraph-separate)) (equal ?^ (aref paragraph-separate 0))) (substring paragraph-separate 1) paragraph-separate)) - (paragraph-separate + (parsep (if fill-prefix-regexp - (concat paragraph-separate "\\|" + (concat parsep "\\|" fill-prefix-regexp "[ \t]*$") - paragraph-separate)) + parsep)) ;; This is used for searching. - (sp-paragraph-start (concat "^[ \t]*\$" paragraph-start "\$")) - start) + (sp-parstart (concat "^[ \t]*\$?:" parstart "\\|" parsep "\$")) + start found-start) (while (and (< arg 0) (not (bobp))) - (if (and (not (looking-at paragraph-separate)) + (if (and (not (looking-at parsep)) (re-search-backward "^\n" (max (1- (point)) (point-min)) t) - (looking-at paragraph-separate)) - nil + (looking-at parsep)) + (setq arg (1+ arg)) (setq start (point)) ;; Move back over paragraph-separating lines. (backward-char 1) (beginning-of-line) (while (and (not (bobp)) (progn (move-to-left-margin) - (looking-at paragraph-separate))) + (looking-at parsep))) (forward-line -1)) (if (bobp) nil + (setq arg (1+ arg)) ;; Go to end of the previous (non-separating) line. (end-of-line) ;; Search back for line that starts or separates paragraphs. (if (if fill-prefix-regexp - ;; There is a fill prefix; it overrides paragraph-start. + ;; There is a fill prefix; it overrides parstart. (let (multiple-lines) (while (and (progn (beginning-of-line) (not (bobp))) (progn (move-to-left-margin) - (not (looking-at paragraph-separate))) + (not (looking-at parsep))) (looking-at fill-prefix-regexp)) - (if (not (= (point) start)) + (unless (= (point) start) (setq multiple-lines t)) (forward-line -1)) (move-to-left-margin) - ;; Don't move back over a line before the paragraph - ;; which doesn't start with fill-prefix - ;; unless that is the only line we've moved over. - (and (not (looking-at fill-prefix-regexp)) - multiple-lines - (forward-line 1)) + ;; This deleted code caused a long hanging-indent line + ;; not to be filled together with the following lines. + ;; ;; Don't move back over a line before the paragraph + ;; ;; which doesn't start with fill-prefix + ;; ;; unless that is the only line we've moved over. + ;; (and (not (looking-at fill-prefix-regexp)) + ;; multiple-lines + ;; (forward-line 1)) (not (bobp))) - (while (and (re-search-backward sp-paragraph-start nil 1) + (while (and (re-search-backward sp-parstart nil 1) + (setq found-start t) ;; Found a candidate, but need to check if it is a - ;; REAL paragraph-start. - (not (bobp)) + ;; REAL parstart. (progn (setq start (point)) (move-to-left-margin) - (not (looking-at paragraph-separate))) - (or (not (looking-at paragraph-start)) - (and use-hard-newlines - (not (get-text-property (1- start) - 'hard))))) + (not (looking-at parsep))) + (not (and (looking-at parstart) + (or (not use-hard-newlines) + (get-text-property (1- start) 'hard) + (bobp))))) + (setq found-start nil) (goto-char start)) - (> (point) (point-min))) + found-start) ;; Found one. (progn ;; Move forward over paragraph separators. ＠＠ -239,7 +275,7 ＠＠ ;; because we know we moved back over a non-separator. (while (and (not (eobp)) (progn (move-to-left-margin) - (looking-at paragraph-separate))) + (looking-at parsep))) (forward-line 1)) ;; If line before paragraph is just margin, back up to there. (end-of-line 0) ＠＠ -249,38 +285,44 ＠＠ (if (not (bolp)) (forward-line 1)))) ;; No starter or separator line => use buffer beg. - (goto-char (point-min))))) - (setq arg (1+ arg))) + (goto-char (point-min)))))) + (while (and (> arg 0) (not (eobp))) - ;; Move forward over separator lines, and one more line. - (while (prog1 (and (not (eobp)) + ;; Move forward over separator lines... + (while (and (not (eobp)) (progn (move-to-left-margin) (not (eobp))) - (looking-at paragraph-separate)) - (forward-line 1))) + (looking-at parsep)) + (forward-line 1)) + (unless (eobp) (setq arg (1- arg))) + ;; ... and one more line. + (forward-line 1) (if fill-prefix-regexp - ;; There is a fill prefix; it overrides paragraph-start. + ;; There is a fill prefix; it overrides parstart. (while (and (not (eobp)) (progn (move-to-left-margin) (not (eobp))) - (not (looking-at paragraph-separate)) + (not (looking-at parsep)) (looking-at fill-prefix-regexp)) (forward-line 1)) - (while (and (re-search-forward sp-paragraph-start nil 1) + (while (and (re-search-forward sp-parstart nil 1) (progn (setq start (match-beginning 0)) (goto-char start) (not (eobp))) (progn (move-to-left-margin) - (not (looking-at paragraph-separate))) - (or (not (looking-at paragraph-start)) + (not (looking-at parsep))) + (or (not (looking-at parstart)) (and use-hard-newlines (not (get-text-property (1- start) 'hard))))) (forward-char 1)) (if (< (point) (point-max)) - (goto-char start))) - (setq arg (1- arg))))) + (goto-char start)))) + (constrain-to-field nil opoint t) + ;; Return the number of steps that could not be done. + arg)) (defun backward-paragraph (&optional arg) "Move backward to start of paragraph. -With arg N, do it N times; negative arg -N means move forward N paragraphs. +With argument ARG, do it ARG times; +a negative argument ARG = -N means move forward N paragraphs. A paragraph start is the beginning of a line which is a `first-line-of-paragraph' or which is ordinary text and follows a ＠＠ -296,16 +338,29 ＠＠ (defun mark-paragraph (&optional arg) "Put point at beginning of this paragraph, mark at end. The paragraph marked is the one that contains point or follows point. -With arg N, puts mark at end of following N paragraphs; -negative arg -N means point is put at end of this paragraph, mark is put -at beginning of this or a previous paragraph." + +With argument ARG, puts mark at end of a following paragraph, so that +the number of paragraphs marked equals ARG. + +If ARG is negative, point is put at end of this paragraph, mark is put +at beginning of this or a previous paragraph. + +If this command is repeated, it marks the next ARG paragraphs after (or +before, if arg is negative) the ones already marked." (interactive "p") (unless arg (setq arg 1)) (when (zerop arg) (error "Cannot mark zero paragraphs")) + (cond ((and (eq last-command this-command) (mark t)) + (set-mark + (save-excursion + (goto-char (mark)) + (forward-paragraph arg) + (point)))) + (t (forward-paragraph arg) (push-mark nil t t) - (backward-paragraph arg)) + (backward-paragraph arg)))) (defun kill-paragraph (arg) "Kill forward to end of paragraph. ＠＠ -359,10 +414,14 ＠＠ sentences. A paragraph boundary also terminates a sentence." (interactive "_p") ; XEmacs (or arg (setq arg 1)) + (let ((opoint (point))) (while (< arg 0) - (let ((par-beg (save-excursion (start-of-paragraph-text) (point)))) - (if (re-search-backward (concat sentence-end "[^ \t\n]") par-beg t) - (goto-char (1- (match-end 0))) + (let ((pos (point)) + (par-beg (save-excursion (start-of-paragraph-text) (point)))) + (if (and (re-search-backward sentence-end par-beg t) + (or (< (match-end 0) pos) + (re-search-backward sentence-end par-beg t))) + (goto-char (match-end 0)) (goto-char par-beg))) (setq arg (1+ arg))) (while (> arg 0) ＠＠ -370,7 +429,8 ＠＠ (if (re-search-forward sentence-end par-end t) (skip-chars-backward " \t\n") (goto-char par-end))) - (setq arg (1- arg)))) + (setq arg (1- arg))) + (constrain-to-field nil opoint t))) (defun backward-sentence (&optional arg) "Move backward to start of sentence. With arg, do it arg times. ＠＠ -392,11 +452,15 ＠＠ (kill-region (point) (progn (backward-sentence arg) (point)))) (defun mark-end-of-sentence (arg) - "Put mark at end of sentence. Arg works as in `forward-sentence'." + "Put mark at end of sentence. Arg works as in `forward-sentence'. +If this command is repeated, it marks the next ARG sentences after the +ones already marked." (interactive "p") ;; FSF Version: ; (push-mark ; (save-excursion +; (if (and (eq last-command this-command) (mark t)) +; (goto-char (mark))) ; (forward-sentence arg) ; (point)) ; nil t)) ＠＠ -407,10 +471,13 ＠＠ (interactive "p") (mark-something 'mark-end-of-line 'end-of-line arg)) - (defun transpose-sentences (arg) "Interchange this (next) and previous sentence." (interactive "*p") (transpose-subr 'forward-sentence arg)) + +;;; Local Variables: +;;; coding: iso-2022-7bit +;;; End: ;;; paragraphs.el ends here

1 participants
0 comments

CVS update: MODIFIED: src ... 20 years, 2 months

CVS Monitor

User: ben Date: 05/02/03 08:11:30 Modified: xemacs/src ChangeLog lread.c lisp.h Added: xemacs/lisp easy-mmode.el regexp-opt.el Log: behavior ws #4: package-suppress, autoload update/sync, add easy-mmode/regexp-opt to core lread.c, lisp.h: Remove undeeded Vload_file_name_internal_the_purecopy, Qload_file_name -- use internal_bind_lisp_object instead of specbind. Add load-suppress-alist. * easy-mmode.el, regexp-opt.el: Move these files into core. Uncomment stuff depending on new custom.el. autoload.el: Removed. Major update. Sync with FSF 21.2. Create the ability to make custom-defines files. update-elc-2.el, update-elc.el: Rewrite to use new autoload API. update-elc.el: Add easy-mmode. Revision Changes Path 1.624 +45 -42 XEmacs/xemacs/lisp/ChangeLog (In the diff below, changes in quantity of whitespace are not shown.) Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/ChangeLog,v retrieving revision 1.623 retrieving revision 1.624 diff -u -b -r1.623 -r1.624 --- ChangeLog 2005/02/03 05:26:39 1.623 +++ ChangeLog 2005/02/03 07:11:19 1.624 ＠＠ -1,5 +1,50 ＠＠ 2005-02-02 Ben Wing <ben(a)xemacs.org> + * easy-mmode.el, regexp-opt.el: + Move these files into core. + Uncomment stuff depending on new custom.el. + + * autoload.el: + * autoload.el (generate-autoload-function): New. + * autoload.el (autoload-feature-suffix): New. + * autoload.el (generate-autoload-section-continuation): New. + * autoload.el (make-autoload): + * autoload.el (generate-file-autoloads): + * autoload.el (generate-autoload-type-section): + * autoload.el (process-one-lisp-autoload): New. + * autoload.el (generate-lisp-file-autoloads-1): + * autoload.el (generate-c-file-autoloads-1): + * autoload.el (generate-custom-defines): New. + * autoload.el (print-autoload): Removed. + * autoload.el (autoload-print-form): New. + * autoload.el (defcustom): + * autoload.el (autoload-read-section-header): New. + * autoload.el (update-file-autoloads): + * autoload.el (update-autoloads-here): Removed. + * autoload.el (batch-update-directory-custom-defines): New. + * autoload.el (update-autoload-files): + * autoload.el (autoload-update-directory-autoloads): Removed. + * autoload.el (batch-update-directory-autoloads): New. + * autoload.el (autoload-featurep-protect-autoloads): + * autoload.el (update-autoloads-from-directory): Removed. + * autoload.el (update-custom-define-files): New. + * autoload.el (autoload-make-feature-name): + * autoload.el (batch-update-autoloads): + * autoload.el (batch-update-directory): Removed. + * autoload.el (batch-update-one-directory): Removed. + * autoload.el (batch-force-update-one-directory): Removed. + Major update. Sync with FSF 21.2. + Create the ability to make custom-defines files. + + * update-elc-2.el (batch-update-elc-2): + * update-elc.el (do-autoload-commands): + Rewrite to use new autoload API. + + * update-elc.el (lisp-files-needing-early-byte-compilation): + Add easy-mmode. + +2005-02-02 Ben Wing <ben(a)xemacs.org> + * behavior.el: * behavior.el (behavior-group-hash-table): New. * behavior.el (behavior-override-hash-table): New. ＠＠ -207,42 +252,6 ＠＠ 2004-11-09 Ben Wing <ben(a)xemacs.org> - * easy-mmode.el, regexp-opt.el: - Move these files into core. - Uncomment stuff depending on new custom.el. - - * autoload.el: - * autoload.el (generate-autoload-function): New. - * autoload.el (autoload-feature-suffix): New. - * autoload.el (generate-autoload-section-continuation): New. - * autoload.el (make-autoload): - * autoload.el (generate-file-autoloads): - * autoload.el (generate-autoload-type-section): - * autoload.el (process-one-lisp-autoload): New. - * autoload.el (generate-lisp-file-autoloads-1): - * autoload.el (generate-c-file-autoloads-1): - * autoload.el (generate-custom-defines): New. - * autoload.el (print-autoload): Removed. - * autoload.el (autoload-print-form): New. - * autoload.el (defcustom): - * autoload.el (autoload-read-section-header): New. - * autoload.el (update-file-autoloads): - * autoload.el (update-autoloads-here): Removed. - * autoload.el (batch-update-directory-custom-defines): New. - * autoload.el (update-autoload-files): - * autoload.el (autoload-update-directory-autoloads): Removed. - * autoload.el (batch-update-directory-autoloads): New. - * autoload.el (autoload-featurep-protect-autoloads): - * autoload.el (update-autoloads-from-directory): Removed. - * autoload.el (update-custom-define-files): New. - * autoload.el (autoload-make-feature-name): - * autoload.el (batch-update-autoloads): - * autoload.el (batch-update-directory): Removed. - * autoload.el (batch-update-one-directory): Removed. - * autoload.el (batch-force-update-one-directory): Removed. - Major update. Sync with FSF 21.2. - Create the ability to make custom-defines files. - * paragraphs.el: * paragraphs.el (paragraphs): New. * paragraphs.el (use-hard-newlines): Removed. ＠＠ -259,12 +268,6 ＠＠ * paragraphs.el (transpose-sentences): Sync to 21.3. Depends on easy-mmode in core. - * update-elc-2.el (batch-update-elc-2): - * update-elc.el (do-autoload-commands): - Rewrite to use new autoload API. - - * update-elc.el (lisp-files-needing-early-byte-compilation): - Add easy-mmode. 2005-01-31 Ben Wing <ben(a)xemacs.org> 1.21 +597 -378 XEmacs/xemacs/lisp/autoload.el (In the diff below, changes in quantity of whitespace are not shown.) Index: autoload.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/autoload.el,v retrieving revision 1.20 retrieving revision 1.21 diff -u -b -r1.20 -r1.21 --- autoload.el 2003/10/15 09:19:10 1.20 +++ autoload.el 2005/02/03 07:11:20 1.21 ＠＠ -2,9 +2,10 ＠＠ ;; Copyright (C) 1991-1994, 1997, 2003 Free Software Foundation, Inc. ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. -;; Copyright (C) 1996, 2000, 2002, 2003 Ben Wing. +;; Copyright (C) 1996, 2000, 2002, 2003, 2004 Ben Wing. -;; Author: Roland McGrath <roland(a)gnu.ai.mit.edu> +;; Original Author: Roland McGrath <roland(a)gnu.ai.mit.edu> +;; Heavily Modified: XEmacs Maintainers ;; Keywords: maint ;; This file is part of XEmacs. ＠＠ -24,13 +25,17 ＠＠ ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; 02111-1307, USA. -;;; Synched up with: Not synched with FSF. +;;; Synched up with: FSF 21.2 by Ben Wing. +;;; Note that update-file-autoloads is seriously modified and not really +;;; syncable. ;;; Commentary: ;; This code keeps auto-autoloads.el files up to date. It interprets ;; magic cookies (of the form ";;;###autoload" in Lisp source files ;; and "/* ###autoload */" in C source files) in various useful ways. +;; It is also used to maintain custom-defines.el files, since most of +;; the logic for computing them is the same as for auto-autoloads.el. ;; Usage ;; ===== ＠＠ -39,8 +44,7 ＠＠ ;; build process, is ;; xemacs -no-packages -batch \ -;; -eval "(setq generated-autoload-file \"PATH\")" \ -;; -l autoload -f autoload-update-directory-autoloads PREFIX DIRECTORY +;; -l autoload -f batch-update-directory-autoloads PREFIX DIRECTORY ;; which causes XEmacs to update the file named by PATH from the .el ;; files in DIRECTORY (but not recursing into subdirectories) and (if ＠＠ -61,24 +65,13 ＠＠ ;; of XEmacs). ;; The probable next step is to fix up the packages to use the -;; `autoload-update-directory-autoloads' API. However, for backward +;; `batch-update-directory-autoloads' API. However, for backward ;; compatibility with XEmacs 21.4 and 21.1, this can't be done quickly. -;; For now the API used in update-elc-2.el: - -;; (let* ((dir "DIRECTORY") -;; (generated-autoload-file (expand-file-name "auto-autoloads.el" dir)) -;; (autoload-package-name "PREFIX")) -;; (update-autoload-files (list muledir)) -;; (byte-recompile-file generated-autoload-file 0)) - -;; is available, but this ugly kludge is deprecated. It will be removed -;; in favor of using proper arguments instead of special variables. - ;; For backward compatibility the API used in the packages/XEmacs.rules: ;; xemacs -vanilla -batch -eval "$(AUTOLOAD_PACKAGE_NAME)" \ -;; -l autoload -f batch-update-directory $(AUTOLOAD_PATH) +;; -l autoload -f batch-update-autoloads $(AUTOLOAD_PATH) ;; is supported, and the implementation is unchanged. However, ;; revision of the API (in a backward compatible way) and the ＠＠ -130,6 +123,10 ＠＠ ;;; Code: +;; Need to load easy-mmode because we expand macro calls to easy-mmode +;; macros in make-autoloads below. +(require 'easy-mmode) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Standard file and directory names ＠＠ -144,6 +141,10 ＠＠ ;; Dynamic variables for communication among functions +;; FSF 21.2: +;; The autoload file is assumed to contain a trailer starting with a FormFeed +;; character. + (defvar generated-autoload-file (expand-file-name autoload-file-name lisp-directory) "*File `update-file-autoloads' puts autoloads into. ＠＠ -154,6 +155,11 ＠＠ generally the file named by `autoload-file-name' in the directory being updated. XEmacs.rules setq's this variable for package autoloads.") +(defvar generate-autoload-function + #'generate-file-autoloads + "Function to generate the autoloads for a file and insert at point. +Called with one argument, the file.") + (define-obsolete-variable-alias 'autoload-package-name 'autoload-feature-prefix) (defvar autoload-feature-prefix nil ＠＠ -164,6 +170,9 ＠＠ auto-autoloads file). Highest priority candidate except for an explicit argument to `autoload-make-feature-name' (q.v.).") +(defvar autoload-feature-suffix "-autoloads" + "String added to `autoload-feature-prefix' to create the autoload feature name.") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Magic strings in source files ＠＠ -210,40 +219,69 ＠＠ (defconst generate-autoload-section-trailer "\n;;;***\n" "String which indicates the end of the section of autoloads for a file.") +(defconst generate-autoload-section-continuation ";;;;;; " + "String to add on each continuation of the section header form.") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Parsing the source file text. -;; Autoloads in C source differ from those in Lisp source. For historical -;; reasons, functions handling only Lisp don't have "lisp" in their names; -;; maybe this should be changed. +;; Autoloads in C source differ from those in Lisp source. (defun make-autoload (form file) - "Turn a definition generator FORM into an autoload for source file FILE. -Returns nil if FORM is not a defun, defun*, defmacro, defmacro*, -define-skeleton, or define-derived-mode." - (let ((car (car-safe form))) - (if (memq car '(defun defun* define-skeleton defmacro defmacro* - define-derived-mode)) - (let ((macrop (memq car '(defmacro defmacro*))) - name doc) - (setq form (cdr form) - name (car form) - ;; Ignore the arguments. - form (cdr (cond ((eq car 'define-skeleton) - form) - ((eq car 'define-derived-mode) - (cddr form)) - (t - (cdr form)))) - doc (car form)) - (if (stringp doc) - (setq form (cdr form)) - (setq doc nil)) - (list 'autoload (list 'quote name) file doc - (or (eq car 'define-skeleton) - (eq car 'define-derived-mode) - (eq (car-safe (car form)) 'interactive)) - (if macrop (list 'quote 'macro) nil))) - nil))) + "Turn FORM into an autoload or defvar for source file FILE. +Returns nil if FORM is not a special autoload form (i.e. a function definition +or macro definition or a defcustom)." + (let ((car (car-safe form)) expand) + (cond + ;; For complex cases, try again on the macro-expansion. + ((and (memq car '(easy-mmode-define-global-mode + easy-mmode-define-minor-mode define-minor-mode)) + (setq expand (let ((load-file-name file)) (macroexpand form))) + (eq (car expand) 'progn) + (memq :autoload-end expand)) + (let ((end (memq :autoload-end expand))) + ;; Cut-off anything after the :autoload-end marker. + (setcdr end nil) + (cons 'progn + (mapcar (lambda (form) (make-autoload form file)) + (cdr expand))))) + + ;; For special function-like operators, use the `autoload' function. + ((memq car '(defun define-skeleton defmacro define-derived-mode + define-generic-mode easy-mmode-define-minor-mode + easy-mmode-define-global-mode + define-minor-mode defun* defmacro*)) + (let* ((macrop (memq car '(defmacro defmacro*))) + (name (nth 1 form)) + (body (nthcdr (get car 'doc-string-elt) form)) + (doc (if (stringp (car body)) (pop body)))) + ;; `define-generic-mode' quotes the name, so take care of that + (list 'autoload (if (listp name) name (list 'quote name)) file doc + (or (and (memq car '(define-skeleton define-derived-mode + define-generic-mode + easy-mmode-define-global-mode + easy-mmode-define-minor-mode + define-minor-mode)) t) + (eq (car-safe (car body)) 'interactive)) + (if macrop (list 'quote 'macro) nil)))) + + ;; Convert defcustom to a simpler (and less space-consuming) defvar, + ;; but add some extra stuff if it uses :require. + ((eq car 'defcustom) + (let ((varname (car-safe (cdr-safe form))) + (init (car-safe (cdr-safe (cdr-safe form)))) + (doc (car-safe (cdr-safe (cdr-safe (cdr-safe form))))) + (rest (cdr-safe (cdr-safe (cdr-safe (cdr-safe form)))))) + (if (not (plist-get rest :require)) + `(defvar ,varname ,init ,doc) + `(progn + (defvar ,varname ,init ,doc) + (custom-add-to-group ,(plist-get rest :group) + ',varname 'custom-variable) + (custom-add-load ',varname + ,(plist-get rest :require)))))) + + ;; nil here indicates that this is not a special autoload form. + (t nil)))) (defun make-c-autoload (module) "Make an autoload list for the DEFUN at point in MODULE. ＠＠ -283,7 +321,7 ＠＠ ;; Generating autoloads for a single file ;;;###autoload -(defun generate-file-autoloads (file &optional funlist) +(defun generate-file-autoloads (file) "Insert at point an autoload section for FILE. autoloads are generated for defuns and defmacros in FILE marked by `generate-autoload-cookie' (which see). ＠＠ -291,26 +329,26 ＠＠ are used." (interactive "fGenerate autoloads for file: ") (cond ((string-match "\\.el$" file) - (generate-autoload-ish-1 + (generate-autoload-type-section file (replace-in-string (file-name-nondirectory file) "\\.elc?$" "") - nil #'generate-file-autoloads-1 - funlist)) + nil #'generate-lisp-file-autoloads-1)) ;; #### jj, are C++ modules possible? ((string-match "\\.c$" file) - (generate-autoload-ish-1 + (generate-autoload-type-section file (replace-in-string (file-name-nondirectory file) "\\.c$" "") - t #'generate-c-file-autoloads-1 - funlist)) + t #'generate-c-file-autoloads-1)) (t (error 'wrong-type-argument file "not a C or Elisp source file")))) -(defun* generate-autoload-ish-1 (file load-name literal fun-to-call &rest args) +(defun* generate-autoload-type-section (file load-name literal fun-to-call) "Insert at point an autoload-type section for FILE. -If LITERAL, open the file literally, without decoding. -Calls FUN-TO-CALL to compute the autoloads, passing it OUTBUF, LOAD-NAME, - TRIM-NAME, and ARGS." +LOAD-NAME is the non-directory portion of the name, with the final .el, .elc +or .c section removed. If LITERAL, open the file literally, without decoding. +Calls FUN-TO-CALL to compute the autoloads, with the loaded file in the +current buffer, passing it OUTBUF (where to write the autoloads), LOAD-NAME, +and TRIM-NAME (result of calling `autoload-trim-file-name' on FILE)." (let ((outbuf (current-buffer)) (trim-name (autoload-trim-file-name file)) (autoloads-done '()) ＠＠ -318,6 +356,7 ＠＠ (print-readably t) ; XEmacs (float-output-format nil) (visited (get-file-buffer file)) + suppress-form ;; (done-any nil) output-end) ＠＠ -329,21 +368,74 ＠＠ ;; subdirectory of the current buffer's directory, we'll make it ;; relative to the current buffer's directory. (setq file (expand-file-name file)) - + ;; #### FSF 21.2. Do we want this? +; (let* ((source-truename (file-truename file)) +; (dir-truename (file-name-as-directory +; (file-truename default-directory))) +; (len (length dir-truename))) +; (if (and (< len (length source-truename)) +; (string= dir-truename (substring source-truename 0 len))) +; (setq file (substring source-truename len)))) + + ;; Check for suppression form (XEmacs) + (let* ((dir (file-name-directory file)) + (_pkg (expand-file-name "_pkg.el" dir)) + (pkg-vis (get-file-buffer _pkg)) + pkg-buf) (save-excursion + (when (file-readable-p _pkg) (unwind-protect (progn (let ((find-file-hooks nil) (enable-local-variables nil)) + (set-buffer (or pkg-vis (find-file-noselect _pkg))) + (set-syntax-table emacs-lisp-mode-syntax-table)) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (block nil + (while (search-forward "(package-suppress" nil t) + ;; skip over package-name + (forward-sexp 1) + (let ((supfile (read (current-buffer)))) + (when (equal supfile load-name) + (setq suppress-form (eval (read (current-buffer)))) + (return)))))))) + (unless pkg-vis + ;; We created this buffer, so we should kill it. + (if pkg-buf (kill-buffer pkg-buf))))))) + + (save-excursion + (unwind-protect + (progn + (let (;(find-file-hooks nil) + ;(enable-local-variables nil) + ) (set-buffer (or visited (find-file-noselect file literal literal ))) ;; This doesn't look right for C files, but it is. The only ;; place we need the syntax table is when snarfing the Lisp ;; function name. (set-syntax-table emacs-lisp-mode-syntax-table)) +; (if visited +; (set-buffer visited) +; ;; It is faster to avoid visiting the file. +; (set-buffer (get-buffer-create " *generate-autoload-file*")) +; (kill-all-local-variables) +; (erase-buffer) +; (setq buffer-undo-list t +; buffer-read-only nil) +; ;; This doesn't look right for C files, but it is. The only +; ;; place we need the syntax table is when snarfing the Lisp +; ;; function name. +; (emacs-lisp-mode) +; (if literal +; (insert-file-contents-literally file nil) +; (insert-file-contents file nil))) (unless (setq autoloads-done - (apply fun-to-call outbuf load-name trim-name args)) - (return-from generate-autoload-ish-1)) + (funcall fun-to-call outbuf load-name trim-name)) + (return-from generate-autoload-type-section)) ) (unless visited ;; We created this buffer, so we should kill it. ＠＠ -354,84 +446,63 ＠＠ ;; XEmacs -- always do this so that we cache the information ;; that we've processed the file already. (progn + ;; Insert the section-header line + ;; which lists the file name and which functions are in it, etc. (insert generate-autoload-section-header) - (prin1 (list 'autoloads autoloads-done load-name trim-name) + (prin1 (list 'autoloads autoloads-done load-name trim-name + ;; In FSF 21.2. Also in FSF 19.30. Presumably + ;; deleted from XEmacs. + ;; (nth 5 (file-attributes file)) + ) outbuf) (terpri outbuf) - ;;;; (insert ";;; Generated autoloads from " - ;;;; (autoload-trim-file-name file) "\n") - ;; Warn if we put a line in auto-autoloads.el - ;; that is long enough to cause trouble. - (when (< output-end (point)) - (setq output-end (point-marker))) - (while (< (point) output-end) - ;; (let ((beg (point))) - (end-of-line) - ;; Emacs -- I still haven't figured this one out. - ;; (if (> (- (point) beg) 900) - ;; (progn - ;; (message "A line is too long--over 900 characters") - ;; (sleep-for 2) - ;; (goto-char output-end))) - ;; ) - (forward-line 1)) + ;; #### Alas, we will have to think about this. Adding this means + ;; that, once we have created or maintained an auto-autoloads file, + ;; we alone and our successors can update the file. The file itself + ;; will work fine in older XEmacsen, but they won't be able to + ;; update autoloads -- hence, to build. +; ;; Break that line at spaces, to avoid very long lines. +; ;; Make each sub-line into a comment. +; (with-current-buffer outbuf +; (save-excursion +; (forward-line -1) +; (while (not (eolp)) +; (move-to-column 64) +; (skip-chars-forward "^ \n") +; (or (eolp) +; (insert "\n" generate-autoload-section-continuation))))) + ;; XEmacs: This was commented out before. #### Correct? +; (insert ";;; Generated autoloads from " +; (autoload-trim-file-name file) "\n") + ;; XEmacs -- handle suppression + (when suppress-form + (insert "\n;;; Suppress form from _pkg.el\n") + (insert "(unless " (prin1-to-string suppress-form) "\n\n")) (goto-char output-end) + ;; XEmacs -- handle suppression + (when suppress-form + (insert "\n) ;; unless (suppressed)\n")) (insert generate-autoload-section-trailer))) - (or noninteractive ; XEmacs: only need one line in -batch mode. - (message "Generating autoloads for %s...done" file)))) + )) -(defun* generate-file-autoloads-1 (outbuf load-name trim-name funlist) - "Insert at point an autoload section for FILE. -autoloads are generated for defuns and defmacros in FILE -marked by `generate-autoload-cookie' (which see). -If FILE is being visited in a buffer, the contents of the buffer -are used." - (let ((autoloads-done '()) - (dofiles (not (null funlist))) - ) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (unless (search-forward generate-autoload-cookie nil t) - (message "No autoloads found in %s" trim-name) - (return-from generate-file-autoloads-1 nil)) - - (message "Generating autoloads for %s..." trim-name) - (goto-char (point-min)) - (while (if dofiles funlist (not (eobp))) - (if (not dofiles) - (skip-chars-forward " \t\n\f") - (goto-char (point-min)) - (re-search-forward - (concat "(def\$un\\|var\\|const\\|macro\$ " - (regexp-quote (symbol-name (car funlist))) - "\\s ")) - (goto-char (match-beginning 0))) - (cond - ((or dofiles - (looking-at (regexp-quote generate-autoload-cookie))) - (if dofiles - nil - (search-forward generate-autoload-cookie) - (skip-chars-forward " \t")) +(defun process-one-lisp-autoload (autoloads-done outbuf load-name) + "Process a single autoload at point and write to OUTBUF. +Point should be just after a magic cookie string (e.g. ;;;###autoload). +Updates AUTOLOADS-DONE and returns the new value." + (skip-chars-forward " \t") ;; (setq done-any t) - (if (or dofiles (eolp)) + (if (eolp) ;; Read the next form and make an autoload. (let* ((form (prog1 (read (current-buffer)) (or (bolp) (forward-line 1)))) - (autoload (make-autoload form load-name)) - (doc-string-elt (get (car-safe form) - 'doc-string-elt))) + (autoload (make-autoload form load-name))) (if autoload (setq autoloads-done (cons (nth 1 form) autoloads-done)) (setq autoload form)) - (print-autoload autoload doc-string-elt outbuf "")) + (autoload-print-form autoload outbuf "")) ;; Copy the rest of the line to the output. - (let ((begin (point))) - ;; (terpri outbuf) (cond ((looking-at "immediate\\s *$") ; XEmacs ;; This is here so that you can automatically ;; have small hook functions copied to ＠＠ -439,23 +510,60 ＠＠ ;; to load a whole file just to get a two-line ;; do-nothing find-file-hook... --Stig (forward-line 1) - (setq begin (point)) + (let ((begin (point))) (forward-sexp) - (forward-line 1)) + (forward-line 1) + (princ (buffer-substring begin (point)) outbuf))) (t - (forward-line 1))) - (princ (buffer-substring begin (point)) outbuf)))) + (princ (buffer-substring + (progn + ;; Back up over whitespace, to preserve it. + (skip-chars-backward " \f\t") + (if (= (char-after (1+ (point))) ? ) + ;; Eat one space. + (forward-char 1)) + (point)) + (progn (forward-line 1) (point))) + outbuf)))) + autoloads-done) + +(defun* generate-lisp-file-autoloads-1 (outbuf load-name trim-name) + "Insert at point in OUTBUF an autoload section for an Elisp file. +The file is assumed to be already loaded and in the current buffer. +autoloads are generated for defuns and defmacros marked by +`generate-autoload-cookie' (which see)." + (let ((autoloads-done '()) + ) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (unless (search-forward generate-autoload-cookie nil t) + (message "No autoloads found in %s" trim-name) + (return-from generate-lisp-file-autoloads-1 nil)) + + (message "Generating autoloads for %s..." trim-name) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward " \t\n\f") + (cond + ((looking-at (regexp-quote generate-autoload-cookie)) + (search-forward generate-autoload-cookie) + (setq autoloads-done + (process-one-lisp-autoload autoloads-done outbuf load-name))) ((looking-at ";") ;; Don't read the comment. (forward-line 1)) (t (forward-sexp 1) (forward-line 1))) - (if dofiles - (setq funlist (cdr funlist)))))) + ))) + (or noninteractive ; XEmacs: only need one line in -batch mode. + (message "Generating autoloads for %s...done" trim-name)) autoloads-done)) -(defun* generate-c-file-autoloads-1 (outbuf load-name trim-name funlist) +(defun* generate-c-file-autoloads-1 (outbuf load-name trim-name + &optional funlist) "Insert at point an autoload section for the C file FILE. autoloads are generated for defuns and defmacros in FILE marked by `generate-c-autoload-cookie' (which see). ＠＠ -488,7 +596,7 ＠＠ (let ((autoload (make-c-autoload load-name))) (when autoload (push (nth 1 (nth 1 autoload)) autoloads-done) - (print-autoload autoload 3 outbuf " ")))) + (autoload-print-form autoload outbuf " ")))) ;; close the princ'd `when' form (princ ")" outbuf)) (goto-char (point-min)) ＠＠ -505,23 +613,107 ＠＠ (let ((autoload (make-c-autoload load-name))) (when autoload (push (nth 1 (nth 1 autoload)) autoloads-done) - (print-autoload autoload 3 outbuf " "))) + (autoload-print-form autoload outbuf " "))) (setq match (search-forward generate-c-autoload-cookie nil t))) ;; close the princ'd `when' form (princ ")" outbuf))))) + (or noninteractive ; XEmacs: only need one line in -batch mode. + (message "Generating autoloads for %s...done" trim-name)) + autoloads-done)) + +;;;###autoload +(defun generate-custom-defines (file) + "Insert at point a custom-define section for FILE. +If FILE is being visited in a buffer, the contents of the buffer +are used." + (interactive "fGenerate custom defines for file: ") + (cond ((string-match "\\.el$" file) + (generate-autoload-type-section + file + (replace-in-string (file-name-nondirectory file) "\\.elc?$" "") + nil #'generate-custom-defines-1)) + ((string-match "\\.c$" file) + ;; no way to generate custom-defines for C files (currently?), + ;; but cannot signal an error. + nil) + (t + (error 'wrong-type-argument file "not a C or Elisp source file")))) + +(defun* generate-custom-defines-1 (outbuf load-name trim-name) + "Insert at point in OUTBUF a custom-define section for an Elisp file. +This contains all defcustoms and defgroups in the file. +The file is assumed to be already loaded and in the current buffer." + (let* ((search-regexp-1 "^(\$defcustom\\|defgroup\$ ") + (search-string-2 ";;;###custom-define") + (search-regexp-2 (regexp-quote search-string-2)) + (autoloads-done '())) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (unless (or (re-search-forward search-regexp-1 nil t) + (re-search-forward search-regexp-2 nil t)) + (message "No custom defines found in %s" trim-name) + (return-from generate-custom-defines-1 nil)) + (message "Generating custom defines for %s..." trim-name) + (princ "(defconst custom-define-current-source-file " outbuf) + (prin1 (file-relative-name (buffer-file-name) + (symbol-value-in-buffer 'default-directory + outbuf)) outbuf) + (princ ")\n" outbuf) + + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward " \t\n\f") + (cond + ((looking-at search-regexp-1) + ;; Read the next form and copy it to make an autoload. + (let* ((form (prog1 (read (current-buffer)) + (or (bolp) (forward-line 1)))) + (autoload form ;(make-autoload form load-name) + )) + (if autoload + (setq autoloads-done (cons (nth 1 form) autoloads-done)) + (setq autoload form)) + (autoload-print-form autoload outbuf "")) + ) + ((looking-at search-regexp-2) + (search-forward search-string-2) + (beep) + (setq autoloads-done + (process-one-lisp-autoload autoloads-done outbuf load-name))) + ((looking-at ";") + ;; Don't read the comment. + (forward-line 1)) + (t + (forward-sexp 1) + (forward-line 1))) + ))) + (or noninteractive ; XEmacs: only need one line in -batch mode. + (message "Generating custom defines for %s...done" trim-name)) + autoloads-done)) ;; Assorted utilities for generating autoloads and pieces thereof -(defun print-autoload (autoload doc-string-elt outbuf margin) +(defun autoload-print-form (form outbuf margin) "Print an autoload form, handling special characters. In particular, print docstrings with escapes inserted before left parentheses at the beginning of lines and ^L characters." - (if (and doc-string-elt (stringp (nth doc-string-elt autoload))) + (cond + ;; If the form is a sequence, recurse. + ((eq (car form) 'progn) + (mapcar #'(lambda (x) (autoload-print-form x outbuf margin)) + (cdr form))) + ;; Symbols at the toplevel are meaningless. + ((symbolp form) nil) + (t + (let ((doc-string-elt (get (car-safe form) 'doc-string-elt))) + (if (and doc-string-elt (stringp (nth doc-string-elt form))) ;; We need to hack the printing because the doc-string must be ;; printed specially for make-docfile (sigh). - (let* ((p (nthcdr (1- doc-string-elt) autoload)) + (let* ((p (nthcdr (1- doc-string-elt) form)) (elt (cdr p)) (start-string (format "\n%s(" margin))) (setcdr p nil) ＠＠ -529,16 +721,14 ＠＠ ;; XEmacs change: don't let ^^L's get into ;; the file or sorting is hard. (let ((print-escape-newlines t) - (p (save-excursion - (set-buffer outbuf) - (point))) + ;;#### FSF 21.2 (print-escape-nonascii t) + (p (point outbuf)) p2) (mapcar #'(lambda (elt) (prin1 elt outbuf) (princ " " outbuf)) - autoload) - (save-excursion - (set-buffer outbuf) + form) + (with-current-buffer outbuf (setq p2 (point-marker)) (goto-char p) (save-match-data ＠＠ -547,14 +737,11 ＠＠ (insert "\\^L"))) (goto-char p2))) (princ "\"\\\n" outbuf) - (let ((begin (save-excursion - (set-buffer outbuf) - (point)))) + (let ((begin (point outbuf))) (princ (substring (prin1-to-string (car elt)) 1) outbuf) ;; Insert a backslash before each ( that appears at the beginning ;; of a line in the doc string. - (save-excursion - (set-buffer outbuf) + (with-current-buffer outbuf (save-excursion (while (search-backward start-string begin t) (forward-char 1) ＠＠ -566,30 +753,35 ＠＠ (terpri outbuf) (princ margin outbuf))) ;; XEmacs change: another ^L hack - (let ((p (save-excursion - (set-buffer outbuf) - (point))) + (let ((p (point outbuf)) (print-escape-newlines t) + ;;#### FSF 21.2 (print-escape-nonascii t) p2) - (print autoload outbuf) - (save-excursion - (set-buffer outbuf) + (print form outbuf) + (with-current-buffer outbuf (setq p2 (point-marker)) (goto-char p) (save-match-data (while (search-forward "\^L" p2 t) (delete-char -1) (insert "\\^L"))) - (goto-char p2))))) + (goto-char p2)))))))) ;;; Forms which have doc-strings which should be printed specially. ;;; A doc-string-elt property of ELT says that (nth ELT FORM) is ;;; the doc-string in FORM. ;;; -;;; defvar and defconst should be also be marked in this way. There is -;;; no interference from make-docfile, which only processes those files -;;; that are loaded into the dumped Emacs, and those files should -;;; never have anything autoloaded here. Problems only occur with files +;;; There used to be the following note here: +;;; ;;; Note: defconst and defvar should NOT be marked in this way. +;;; ;;; We don't want to produce defconsts and defvars that +;;; ;;; make-docfile can grok, because then it would grok them twice, +;;; ;;; once in foo.el (where they are given with ;;;###autoload) and +;;; ;;; once in loaddefs.el. +;;; +;;; Counter-note: Yes, they should be marked in this way. +;;; make-docfile only processes those files that are loaded into the +;;; dumped Emacs, and those files should never have anything +;;; autoloaded here. The above-feared problem only occurs with files ;;; which have autoloaded entries *and* are processed by make-docfile; ;;; there should be no such files. ＠＠ -597,11 +789,18 ＠＠ (put 'defun 'doc-string-elt 3) (put 'defun* 'doc-string-elt 3) (put 'defvar 'doc-string-elt 3) +(put 'defcustom 'doc-string-elt 3) (put 'defconst 'doc-string-elt 3) (put 'defmacro 'doc-string-elt 3) (put 'defmacro* 'doc-string-elt 3) -(put 'define-skeleton 'doc-string-elt 3) +(put 'defsubst 'doc-string-elt 3) +(put 'define-skeleton 'doc-string-elt 2) (put 'define-derived-mode 'doc-string-elt 4) +(put 'easy-mmode-define-minor-mode 'doc-string-elt 2) +(put 'define-minor-mode 'doc-string-elt 2) +(put 'define-generic-mode 'doc-string-elt 7) +;; defin-global-mode has no explicit docstring. +(put 'easy-mmode-define-global-mode 'doc-string-elt 1000) (defun autoload-trim-file-name (file) "Returns relative pathname of FILE including the last directory. ＠＠ -615,6 +814,27 ＠＠ ;; #### is this a good idea? "\\\\" "/")) +(defun autoload-read-section-header () + "Read a section header form. +Since continuation lines have been marked as comments, +we must copy the text of the form and remove those comment +markers before we call `read'." + (save-match-data + (let ((beginning (point)) + string) + (forward-line 1) + (while (looking-at generate-autoload-section-continuation) + (forward-line 1)) + (setq string (buffer-substring beginning (point))) + (with-current-buffer (get-buffer-create " *autoload*") + (erase-buffer) + (insert string) + (goto-char (point-min)) + (while (search-forward generate-autoload-section-continuation nil t) + (replace-match " ")) + (goto-char (point-min)) + (read (current-buffer)))))) + ;;;###autoload (defun update-file-autoloads (file) "Update the autoloads for FILE in `generated-autoload-file' ＠＠ -633,16 +853,42 ＠＠ (trim-name (autoload-trim-file-name file)) section-begin form) (save-excursion + ;; FSF has: [[ We want to get a value for generated-autoload-file + ;; from the local variables section if it's there. ]] Not + ;; applicable in XEmacs, since we always keep the autoloads + ;; up-to-date. + + ;; #### FSF 21.2 adds: [[ We must read/write the file without any + ;; code conversion, but still decode EOLs. ]] Not clear if we need + ;; this. --ben + ;; (let ((coding-system-for-read 'raw-text)) (let ((find-file-hooks nil)) (set-buffer (or (get-file-buffer generated-autoload-file) (find-file-noselect generated-autoload-file)))) + ;; FSF 21.2 says: + + ;; [[ This is to make generated-autoload-file have Unix EOLs, so + ;; that it is portable to all platforms. ]] + ;; (setq buffer-file-coding-system 'raw-text-unix)) + ;; Not applicable in XEmacs, since we always keep the autoloads + ;; up-to-date and recompile when we build. + + ;; FSF 21.2: [not applicable to XEmacs] +; (or (> (buffer-size) 0) +; (error "Autoloads file %s does not exist" buffer-file-name)) +; (or (file-writable-p buffer-file-name) +; (error "Autoloads file %s is not writable" buffer-file-name)) + + ;; NOTE: The rest of this function is totally changed from FSF. + ;; Hence, not synched. + ;; Make sure we can scribble in it. (setq buffer-read-only nil) ;; First delete all sections for this file. (goto-char (point-min)) (while (search-forward generate-autoload-section-header nil t) (setq section-begin (match-beginning 0)) - (setq form (read (current-buffer))) + (setq form (autoload-read-section-header)) (when (string= (nth 2 form) load-name) (search-forward generate-autoload-section-trailer) (delete-region section-begin (point)))) ＠＠ -651,7 +897,7 ＠＠ (block find-insertion-point (goto-char (point-min)) (while (search-forward generate-autoload-section-header nil t) - (setq form (read (current-buffer))) + (setq form (autoload-read-section-header)) (when (string< trim-name (nth 3 form)) ;; Found alphabetically correct insertion point (goto-char (match-beginning 0)) ＠＠ -661,65 +907,15 ＠＠ (goto-char (point-max)))) ; Append. ;; Add in new sections for file - (generate-file-autoloads file)) + (funcall generate-autoload-function file)) (when (interactive-p) (save-buffer))))) -;;;###autoload -(defun update-autoloads-here () - "Update sections of the current buffer generated by `update-file-autoloads'." - (interactive) - (let ((generated-autoload-file (buffer-file-name))) - (save-excursion - (goto-char (point-min)) - (while (search-forward generate-autoload-section-header nil t) - (let* ((form (condition-case () - (read (current-buffer)) - (end-of-file nil))) - (file (nth 3 form))) - ;; XEmacs change: if we can't find the file as specified, look - ;; around a bit more. - (cond ((and (stringp file) - (or (get-file-buffer file) - (file-exists-p file)))) - ((and (stringp file) - (save-match-data - (let ((loc (locate-file (file-name-nondirectory file) - load-path))) - (if (null loc) - nil - (setq loc (expand-file-name - (autoload-trim-file-name loc) - "..")) - (if (or (get-file-buffer loc) - (file-exists-p loc)) - (setq file loc) - nil)))))) - (t - (setq file - (if (y-or-n-p - (format - "Can't find library `%s'; remove its autoloads? " - (nth 2 form) file)) - t - (condition-case () - (read-file-name - (format "Find `%s' load file: " - (nth 2 form)) - nil nil t) - (quit nil)))))) - (if file - (let ((begin (match-beginning 0))) - (search-forward generate-autoload-section-trailer) - (delete-region begin (point)))) - (if (stringp file) - (generate-file-autoloads file))))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Utilities for batch updates ;;;###autoload -(defun autoload-update-directory-autoloads () +(defun batch-update-directory-autoloads () "Update the autoloads for a directory, using a specified feature prefix. Must be used only with -batch. The feature prefix and directory to update are taken from the first and second elements of `command-line-args-left', ＠＠ -730,16 +926,33 ＠＠ applying `autoload-make-feature-name' to the specified feature prefix. #### The API and semantics of this function are subject to change." + (unless noninteractive + (error "batch-update-directory-autoloads: may be used only with -batch")) + (update-autoload-files (list (cadr command-line-args-left)) + (car command-line-args-left) nil t) + (setq command-line-args-left (cddr command-line-args-left))) + +;;;###autoload +(defun batch-update-directory-custom-defines () + "Update the custom defines for a directory, using a specified feature prefix. +Must be used only with -batch. The feature prefix and directory to update +are taken from the first and second elements of `command-line-args-left', +respectively, and they are then removed from `command-line-args-left'. + +Runs `update-file-autoloads' on each file in the given directory. Always +rewrites the autoloads file, even if unchanged. Makes a feature name by +applying `autoload-make-feature-name' to the specified feature prefix. + +#### The API and semantics of this function are subject to change." (unless noninteractive - (error "autoload-batch-update-autoloads: may be used only with -batch")) - (let* ((autoload-feature-prefix (car command-line-args-left)) - (dir (cadr command-line-args-left)) - (generated-autoload-file (expand-file-name autoload-file-name dir))) - (update-autoload-files (list dir) t t) - (setq command-line-args-left (cddr command-line-args-left)))) + (error "batch-update-directory-custom-defines: may be used only with -batch")) + (update-custom-define-files (list (cadr command-line-args-left)) + (car command-line-args-left) nil t) + (setq command-line-args-left (cddr command-line-args-left))) ;;;###autoload -(defun update-autoload-files (files-or-dirs &optional all-into-one-file force) +(defun update-autoload-files (files-or-dirs feature-prefix + &optional into-file force) "Update all the autoload files associated with FILES-OR-DIRS. FILES-OR-DIRS is a list of files and/or directories to be processed. ＠＠ -747,61 +960,41 ＠＠ each element of FILES-OR-DIRS. Fixup code testing for the autoload file's feature and to provide the feature is added. -If optional ALL-INTO-ONE-FILE is non-`nil', `generated-autoload-file' -should be set to the name of an autoload file and all autoloads will be -placed in that file. `autoload-feature-prefix' should be set to an -appropriate prefix which will be concatenated with \"-autoloads\" to -produce the feature name. Otherwise the appropriate autoload file for -each file or directory (located in that directory, or in the directory of -the specified file) will be updated with the directory's or file's -autoloads and the protective forms will be added, and the files will be -saved. Use of the default here is unreliable, and therefore deprecated. +If optional INTO-FILE is non-`nil', it should specify a file into which +the autoloads will be placed. Otherwise, the autoloads will be placed into +a file named `auto-autoloads.el' in the directory of each element in +FILES-OR-DIRS. + +FEATURE-PREFIX should be set to an appropriate prefix which will +be concatenated with \"-autoloads\" to produce the feature name. Otherwise +the appropriate autoload file for each file or directory (located in that +directory, or in the directory of the specified file) will be updated with +the directory's or file's autoloads and the protective forms will be added, +and the files will be saved. Use of the default here is unreliable, and +therefore deprecated. Note that if some of FILES-OR-DIRS are directories, recursion goes only one level deep. If FORCE is non-nil, always save out the autoload files even if unchanged." + (or (listp files-or-dirs) (setq files-or-dirs (list files-or-dirs))) (let ((defdir (directory-file-name default-directory)) ;; value for all-into-one-file - (autoload-feature-name (autoload-make-feature-name)) - (enable-local-eval nil)) ; Don't query in batch mode. + (autoload-feature-name (autoload-make-feature-name feature-prefix)) + (enable-local-eval nil) ; Don't query in batch mode. + (autoload-feature-prefix feature-prefix) + ;; protect from change + (generated-autoload-file generated-autoload-file)) (dolist (arg files-or-dirs) (setq arg (expand-file-name arg defdir)) (cond ((file-directory-p arg) + (setq generated-autoload-file + (or into-file (expand-file-name autoload-file-name arg))) (message "Updating autoloads for directory %s..." arg) - (update-autoloads-from-directory arg)) - ((file-exists-p arg) - (update-file-autoloads arg)) - (t (error "No such file or directory: %s" arg))) - (when (not all-into-one-file) - (autoload-featurep-protect-autoloads - (autoload-make-feature-name - (file-name-nondirectory (directory-file-name arg)))) - (if force (set-buffer-modified-p - t (find-file-noselect generated-autoload-file))))) - (when all-into-one-file - (autoload-featurep-protect-autoloads autoload-feature-name) - (if force (set-buffer-modified-p - t (find-file-noselect generated-autoload-file)))) - (save-some-buffers t) - )) - -;;;###autoload -(defun update-autoloads-from-directory (dir) - "Update `generated-autoload-file' with all the current autoloads from DIR. -This runs `update-file-autoloads' on each .el and .c file in DIR. -Obsolete autoload entries for files that no longer exist are deleted. -Note that, if this function is called from `batch-update-directory', -`generated-autoload-file' was rebound in that function. - -You don't really want to be calling this function. Try using -`update-autoload-files' instead." - (interactive "DUpdate autoloads for directory: ") - (setq dir (expand-file-name dir)) (let ((simple-dir (file-name-as-directory (file-name-nondirectory - (directory-file-name dir)))) + (directory-file-name arg)))) (enable-local-eval nil)) (save-excursion (let ((find-file-hooks nil)) ＠＠ -809,36 +1002,102 ＠＠ (goto-char (point-min)) (while (search-forward generate-autoload-section-header nil t) (let* ((begin (match-beginning 0)) - (form (condition-case () - (read (current-buffer)) - (end-of-file nil))) + (form (autoload-read-section-header)) (file (nth 3 form))) (when (and (stringp file) (string= (file-name-directory file) simple-dir) (not (file-exists-p (expand-file-name - (file-name-nondirectory file) dir)))) + (file-name-nondirectory file) arg)))) ;; Remove the obsolete section. (search-forward generate-autoload-section-trailer) (delete-region begin (point))))) ;; Update or create autoload sections for existing files. (mapcar 'update-file-autoloads - (directory-files dir t "^[^=].*\\.\$el\\|c\$$")) - (unless noninteractive - (save-buffer))))) + (directory-files arg t "^[^=].*\\.\$el\\|c\$$"))))) + ((file-exists-p arg) + (setq generated-autoload-file + (or into-file (expand-file-name autoload-file-name + (file-name-directory arg)))) + (update-file-autoloads arg)) + (t (error "No such file or directory: %s" arg))) + (when (not into-file) + (autoload-featurep-protect-autoloads + (autoload-make-feature-name + (or feature-prefix + (file-name-nondirectory (directory-file-name arg))))) + (if force (set-buffer-modified-p + t (find-file-noselect generated-autoload-file))))) + (when into-file + (autoload-featurep-protect-autoloads autoload-feature-name) + (if force (set-buffer-modified-p + t (find-file-noselect into-file)))) + (save-some-buffers t) + )) +;;;###autoload +(defun update-custom-define-files (files-or-dirs feature-prefix + &optional into-file force) + "Update all the custom-define files associated with FILES-OR-DIRS. +Works just like `update-file-autoloads'." + (let* ((autoload-feature-suffix "-custom-defines") + (autoload-file-name "custom-defines.el") + (generate-autoload-function #'generate-custom-defines)) + (update-autoload-files files-or-dirs feature-prefix into-file force))) + (defun autoload-featurep-protect-autoloads (sym) (save-excursion (set-buffer (find-file-noselect generated-autoload-file)) + (goto-char (point-min)) + (cond ((eq (point-min) (point-max)) nil) + ;; if there's some junk in the file but no sections, just + ;; delete everything. the junk might be stuff inserted by + ;; an older version of this function. + ((not (search-forward generate-autoload-section-header nil t)) + (delete-region (point-min) (point-max))) + (t (goto-char (point-min)) - (if (and (not (= (point-min) (point-max))) - (not (looking-at ";;; DO NOT MODIFY THIS FILE"))) + (when (looking-at ";;; DO NOT MODIFY THIS FILE") + (delete-region (point-min) (progn - (insert ";;; DO NOT MODIFY THIS FILE\n") - (insert "(if (featurep '" sym ")") + (search-forward generate-autoload-section-header) + (match-beginning 0)))) + ;; Determine and set the coding system for the file if under Mule. + ;; If there are any extended characters in the input file, use + ;; `escape-quoted' to make sure that both binary and extended + ;; characters are output properly and distinguished properly. + ;; Otherwise, use `raw-text' for maximum portability with non-Mule + ;; Emacsen. + (if (or (featurep '(not mule)) ;; Don't scan if no Mule support + (progn + (goto-char (point-min)) + ;; mrb- There must be a better way than skip-chars-forward + (skip-chars-forward (concat (char-to-string 0) "-" + (char-to-string 255))) + (eq (point) (point-max)))) + (setq buffer-file-coding-system 'raw-text-unix) + (setq buffer-file-coding-system 'escape-quoted)) + (goto-char (point-min)) + (insert ";;; DO NOT MODIFY THIS FILE") + ;; NOTE: XEmacs prior to 21.5.12 or so had a bug in that it + ;; recognized only one of the two magic-cookie styles (the -*- kind) + ;; in find-file, but both of them in load. We go ahead and put both + ;; in, just to be safe. + (when (eq buffer-file-coding-system 'escape-quoted) + (insert " -*- coding: escape-quoted; -*- +\(or (featurep 'mule) (error \"Loading this file requires Mule support\")) +;;;###coding system: escape-quoted")) + (insert "\n(if (featurep '" sym ")") (insert " (error \"Feature " sym " already loaded\"))\n") (goto-char (point-max)) - (insert "\n(provide '" sym ")\n"))))) + (save-excursion + (forward-line -1) + (when (looking-at "(provide") + (delete-region (point) (point-max)))) + (unless (bolp) (insert "\n")) + (unless (eq (char-before (1- (point))) ?\^L) + (insert "\^L\n")) + (insert "(provide '" sym ")\n"))))) (defun autoload-make-feature-name (&optional prefix) "Generate the feature name to protect this auto-autoloads file from PREFIX. ＠＠ -864,19 +1123,23 ＠＠ (file-name-directory generated-autoload-file)))) (t (error 'invalid-argument "Could not compute a feature name"))) - "-autoloads")) + autoload-feature-suffix)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Deprecated entry points ;; A grep of the core and packages shows use of `batch-update-autoloads' ;; by XEmacs.rules, pcomplete, eshell, oort-gnus; `batch-update-directory' -;; by liece. +;; by liece. The other two entry points (`batch-update-one-directory', +;; `batch-force-update-one-directory') were not used at all. +;; +;; All except the first are now history. liece has been updated. +;; XEmacs.rules has been updated. The others will be, eventually. + +;; There don't seem to be very many packages that use the first one (the +;; "all-into-one-file" variety), and do they actually rely on this +;; functionality? --ben -;; #### these entry points below are a big mess, especially the -;; first two. there don't seem to be very many packages that use the -;; first one (the "all-into-one-file" variety), and do they actually -;; rely on this functionality? --ben ;; but XEmacs.rules does, though maybe it doesn't "rely" on it, and ;; modules do now, and that relies on it. --sjt ＠＠ -891,58 +1154,14 ＠＠ on the command line." (unless noninteractive (error "batch-update-autoloads is to be used only with -batch")) - (update-autoload-files command-line-args-left t) + (update-autoload-files command-line-args-left generated-autoload-file) (kill-emacs 0)) -;;;###autoload -(defun batch-update-directory () - "Update the autoloads for the directories on the command line. -Runs `update-file-autoloads' on each file in the given directory, and must -be used only with -batch. - -Uses and removes the first element of `command-line-args-left'." - (unless noninteractive - (error "batch-update-directory is to be used only with -batch")) - (update-autoload-files command-line-args-left) - ;; (kill-emacs 0) - (setq command-line-args-left nil)) - -;;;###autoload -(defun batch-update-one-directory () - "Update the autoloads for a single directory on the command line. -Runs `update-file-autoloads' on each file in the given directory, and must -be used only with -batch." - (unless noninteractive - (error "batch-update-one-directory is to be used only with -batch")) - (let ((arg (car command-line-args-left))) - (setq command-line-args-left (cdr command-line-args-left)) - (update-autoload-files (list arg)))) - -;;;###autoload -(defun batch-force-update-one-directory () - "Update the autoloads for a single directory on the command line. -Runs `update-file-autoloads' on each file in the given directory, and must -be used only with -batch. Always rewrites the autoloads file, even if -unchanged. - -Uses and removes the first element of `command-line-args-left'." - (unless noninteractive - (error "batch-force-update-directory is to be used only with -batch")) - (let ((arg (car command-line-args-left))) - (setq command-line-args-left (cdr command-line-args-left)) - (update-autoload-files (list arg) nil t))) - ;; Declare obsolescence (make-obsolete-variable 'autoload-target-directory "Don't use this. Bind `generated-autoload-file' to an absolute path.") (make-obsolete 'batch-update-autoloads - 'autoload-update-directory-autoloads) -(make-obsolete 'batch-update-directory - 'autoload-update-directory-autoloads) -(make-obsolete 'batch-update-one-directory - 'autoload-update-directory-autoloads) -(make-obsolete 'batch-force-update-one-directory 'autoload-update-directory-autoloads) (provide 'autoload) 1.35 +3 -3 XEmacs/xemacs/lisp/update-elc.el (In the diff below, changes in quantity of whitespace are not shown.) Index: update-elc.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/update-elc.el,v retrieving revision 1.34 retrieving revision 1.35 diff -u -b -r1.34 -r1.35 --- update-elc.el 2004/12/27 12:25:15 1.34 +++ update-elc.el 2005/02/03 07:11:20 1.35 ＠＠ -106,7 +106,7 ＠＠ ;; early byte compilation. These are files loaded by update-elc.el in ;; order to do the compilation of all the rest of the files. (defvar lisp-files-needing-early-byte-compilation - '(;"easy-mmode" + '("easy-mmode" "autoload" "shadow" "cl-macs")) ＠＠ -312,10 +312,10 ＠＠ need-to-rebuild-mule-autoloads) (list "-l" "autoload")) (if need-to-rebuild-autoloads - (list "-f" "autoload-update-directory-autoloads" + (list "-f" "batch-update-directory-autoloads" "auto" source-lisp)) (if need-to-rebuild-mule-autoloads - (list "-f" "autoload-update-directory-autoloads" + (list "-f" "batch-update-directory-autoloads" "mule" source-lisp-mule)) (if need-to-recompile-autoloads (list "-f" "batch-byte-compile-one-file" 1.12 +12 -19 XEmacs/xemacs/lisp/update-elc-2.el (In the diff below, changes in quantity of whitespace are not shown.) Index: update-elc-2.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/update-elc-2.el,v retrieving revision 1.11 retrieving revision 1.12 diff -u -b -r1.11 -r1.12 --- update-elc-2.el 2003/03/01 07:25:27 1.11 +++ update-elc-2.el 2005/02/03 07:11:20 1.12 ＠＠ -149,32 +149,25 ＠＠ ;; way is slow, so we avoid it when possible. (when (file-exists-p (expand-file-name "REBUILD_AUTOLOADS" invocation-directory)) - (let ((generated-autoload-file (expand-file-name "auto-autoloads.el" dir)) - (autoload-package-name "auto")) ; feature prefix ;; if we were instructed to rebuild the autoloads, force the file ;; to be touched even w/o changes; otherwise, we won't ever stop ;; being told to rebuild them. - (update-autoload-files (list dir) nil t) - (byte-recompile-file generated-autoload-file 0)) + (update-autoload-files dir "auto" nil t) + (byte-recompile-file (expand-file-name "auto-autoloads.el" dir) 0) (when (featurep 'mule) - (let* ((muledir (expand-file-name "../lisp/mule" (file-truename dir))) - (generated-autoload-file - (expand-file-name "auto-autoloads.el" muledir)) - (autoload-package-name "mule")) ; feature prefix + (let ((muledir (expand-file-name "../lisp/mule" (file-truename dir)))) ;; force here just like above. - (update-autoload-files (list muledir) nil t) - (byte-recompile-file generated-autoload-file 0)))) + (update-autoload-files muledir "mule" nil t) + (byte-recompile-file (expand-file-name "auto-autoloads.el" dir) 0)))) (when (featurep 'modules) (let* ((moddir (expand-file-name "../modules" (file-truename dir))) - (generated-autoload-file - (expand-file-name "auto-autoloads.el" moddir)) - (autoload-package-name "modules")) ; feature prefix + (autofile (expand-file-name "auto-autoloads.el" moddir))) (update-autoload-files (delete (concat (file-name-as-directory moddir) ".") (delete (concat (file-name-as-directory moddir) "..") (directory-files moddir t nil nil 0))) - t) - (byte-recompile-file generated-autoload-file 0))) + "modules" autofile) + (byte-recompile-file autofile 0))) ;; now load the (perhaps newly rebuilt) autoloads; we were called with ;; -no-autoloads so they're not already loaded. (load (expand-file-name "auto-autoloads" lisp-directory)) 1.1 XEmacs/xemacs/lisp/easy-mmode.el Index: easy-mmode.el =================================================================== ;;; easy-mmode.el --- easy definition for major and minor modes ;; Copyright (C) 1997, 2000, 2001 Free Software Foundation, Inc. ;; Author: Georges Brun-Cottan <Georges.Brun-Cottan(a)inria.fr> ;; Maintainer: Stefan Monnier <monnier(a)gnu.org> ;; Keywords: extensions lisp ;; This file is part of XEmacs. ;; XEmacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; XEmacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Synched up with: GNU Emacs 21.3. ;;; Commentary: ;; Minor modes are useful and common. This package makes defining a ;; minor mode easy, by focusing on the writing of the minor mode ;; functionalities themselves. Moreover, this package enforces a ;; conventional naming of user interface primitives, making things ;; natural for the minor-mode end-users. ;; For each mode, easy-mmode defines the following: ;; <mode> : The minor mode predicate. A buffer-local variable. ;; <mode>-map : The keymap possibly associated to <mode>. ;; <mode>-hook,<mode>-on-hook,<mode>-off-hook and <mode>-mode: ;; see `define-minor-mode' documentation ;; ;; eval ;; (pp (macroexpand '(define-minor-mode <your-mode> <doc>))) ;; to check the result before using it. ;; The order in which minor modes are installed is important. Keymap ;; lookup proceeds down minor-mode-map-alist, and the order there ;; tends to be the reverse of the order in which the modes were ;; installed. Perhaps there should be a feature to let you specify ;; orderings. ;; Additionally to `define-minor-mode', the package provides convenient ;; ways to define keymaps, and other helper functions for major and minor ;; modes. ;;; Code: (eval-when-compile (require 'cl)) ;;; This file uses two functions that did not exist in some versions of ;;; XEmacs: propertize and replace-regexp-in-string. We provide these ;;; functions here for such XEmacsen. ;;; ;;; FIXME: These function definitions should go into the future or ;;; forward-compat package, once that package exists. ;; XEmacs <= 21.4 does not have propertize, but XEmacs >= 21.5 dumps it (it is ;; defined in subr.el). Therefore, it is either defined regardless of what ;; has been loaded already, or it won't be defined regardless of what is ;; loaded. (if (not (fboundp 'propertize)) (defun propertize (string &rest properties) "Return a copy of STRING with text properties added. First argument is the string to copy. Remaining arguments form a sequence of PROPERTY VALUE pairs for text properties to add to the result." (let ((str (copy-sequence string))) (add-text-properties 0 (length str) properties str) str))) ;; XEmacs <= 21.4 does not have replace-regexp-in-string, but XEmacs >= 21.5 ;; dumps it (it is defined in subr.el). Therefore, it is either defined ;; regardless of what has been loaded already, or it won't be defined ;; regardless of what is loaded. (if (not (fboundp 'replace-regexp-in-string)) (defun replace-regexp-in-string (regexp rep string &optional fixedcase literal subexp start) "Replace all matches for REGEXP with REP in STRING. Return a new string containing the replacements. Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the arguments with the same names of function `replace-match'. If START is non-nil, start replacements at that index in STRING. REP is either a string used as the NEWTEXT arg of `replace-match' or a function. If it is a function it is applied to each match to generate the replacement passed to `replace-match'; the match-data at this point are such that match 0 is the function's argument. To replace only the first match (if any), make REGEXP match up to \\' and replace a sub-expression, e.g. (replace-regexp-in-string \"\$foo\$.*\\'\" \"bar\" \" foo foo\" nil nil 1) => \" bar foo\" " (let ((l (length string)) (start (or start 0)) matches str mb me) (save-match-data (while (and (< start l) (string-match regexp string start)) (setq mb (match-beginning 0) me (match-end 0)) ;; If we matched the empty string, make sure we advance by one char (when (= me mb) (setq me (min l (1+ mb)))) ;; Generate a replacement for the matched substring. ;; Operate only on the substring to minimize string consing. ;; Set up match data for the substring for replacement; ;; presumably this is likely to be faster than munging the ;; match data directly in Lisp. (string-match regexp (setq str (substring string mb me))) (setq matches (cons (replace-match (if (stringp rep) rep (funcall rep (match-string 0 str))) fixedcase literal str subexp) (cons (substring string start mb) ; unmatched prefix matches))) (setq start me)) ;; Reconstruct a string from the pieces. (setq matches (cons (substring string start l) matches)) ; leftover (apply #'concat (nreverse matches)))))) (defun easy-mmode-pretty-mode-name (mode &optional lighter) "Turn the symbol MODE into a string intended for the user. If provided LIGHTER will be used to help choose capitalization." (let* ((case-fold-search t) (name (concat (replace-regexp-in-string "-Minor" " minor" (capitalize (replace-regexp-in-string "-mode\\'" "" (symbol-name mode)))) " mode"))) (if (not (stringp lighter)) name (setq lighter (replace-regexp-in-string "\\`\\s-+\\|\\-s+\\'" "" lighter)) (replace-regexp-in-string lighter lighter name t t)))) ;; XEmacs change: add -on-hook, -off-hook, and macro parameter documentation. ;;;###no-autoload (defalias 'easy-mmode-define-minor-mode 'define-minor-mode) ;;;###no-autoload (defmacro define-minor-mode (mode doc &optional init-value lighter keymap &rest body) "Define a new minor mode MODE. This function defines the associated control variable MODE, keymap MODE-map, toggle command MODE, and hook MODE-hook. DOC is the documentation for the mode toggle command. Optional INIT-VALUE is the initial value of the mode's variable. Optional LIGHTER is displayed in the modeline when the mode is on. Optional KEYMAP is the default (defvar) keymap bound to the mode keymap. If it is a list, it is passed to `easy-mmode-define-keymap' in order to build a valid keymap. It's generally better to use a separate MODE-map variable than to use this argument. The above three arguments can be skipped if keyword arguments are used (see below). BODY contains code that will be executed each time the mode is (de)activated. It will be executed after any toggling but before running the hooks. Before the actual body code, you can write keyword arguments (alternating keywords and values). These following keyword arguments are supported: :group GROUP Custom group name to use in all generated `defcustom' forms. :global GLOBAL If non-nil specifies that the minor mode is not meant to be buffer-local, so don't make the variable MODE buffer-local. By default, the mode is buffer-local. :init-value VAL Same as the INIT-VALUE argument. :lighter SPEC Same as the LIGHTER argument. :require SYM Same as in `defcustom'. For backwards compatibility, these hooks are run each time the mode is $de)activated. When the mode is toggled, MODE-hook is always run before the other hook. MODE-hook: run if the mode is toggled. MODE-on-hook: run if the mode is activated. MODE-off-hook: run if the mode is deactivated. \(defmacro easy-mmode-define-minor-mode (MODE DOC &optional INIT-VALUE LIGHTER KEYMAP &rest BODY)...$ For example, you could write (define-minor-mode foo-mode \"If enabled, foo on you!\" nil \"Foo \" foo-keymap :require 'foo :global t :group 'inconvenience ...BODY CODE...)" ;; Allow skipping the first three args. (cond ((keywordp init-value) (setq body (list* init-value lighter keymap body) init-value nil lighter nil keymap nil)) ((keywordp lighter) (setq body (list* lighter keymap body) lighter nil keymap nil)) ((keywordp keymap) (push keymap body) (setq keymap nil))) (let* ((mode-name (symbol-name mode)) (pretty-name (easy-mmode-pretty-mode-name mode lighter)) (globalp nil) (group nil) (extra-args nil) (require t) (keymap-sym (if (and keymap (symbolp keymap)) keymap (intern (concat mode-name "-map")))) (hook (intern (concat mode-name "-hook"))) (hook-on (intern (concat mode-name "-on-hook"))) (hook-off (intern (concat mode-name "-off-hook")))) ;; Check keys. (while (keywordp (car body)) (case (pop body) (:init-value (setq init-value (pop body))) (:lighter (setq lighter (pop body))) (:global (setq globalp (pop body))) (:extra-args (setq extra-args (pop body))) (:group (setq group (nconc group (list :group (pop body))))) (:require (setq require (pop body))) (t (pop body)))) (unless group ;; We might as well provide a best-guess default group. (setq group `(:group ',(or (custom-current-group) (intern (replace-regexp-in-string "-mode\\'" "" mode-name)))))) ;; Add default properties to LIGHTER. ;; #### FSF comments this out in 21.3. ; (unless (or (not (stringp lighter)) ; (get-text-property 0 'local-map lighter) ; (get-text-property 0 'keymap lighter)) ; (setq lighter ; (propertize lighter ; 'local-map modeline-minor-mode-map ; XEmacs change ; 'help-echo "mouse-3: minor mode menu"))) `(progn ;; Define the variable to enable or disable the mode. ,(if (not globalp) `(progn (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled. Use the command `%s' to change this variable." pretty-name mode)) (make-variable-buffer-local ',mode)) (let ((curfile (or (and (boundp 'byte-compile-current-file) byte-compile-current-file) load-file-name))) `(defcustom ,mode ,init-value ,(format "Non-nil if %s is enabled. See the command `%s' for a description of this minor-mode. Setting this variable directly does not take effect; use either \\[customize] or the function `%s'." pretty-name mode mode) :set (lambda (symbol value) (funcall symbol (or value 0))) :initialize 'custom-initialize-default ,＠group :type 'boolean ,＠(cond ((not (and curfile require)) nil) ((not (eq require t)) `(:require ,require)) (t `(:require ',(intern (file-name-nondirectory (file-name-sans-extension curfile))))))))) ;; The actual function. (defun ,mode (&optional arg ,＠extra-args) ,(or doc (format (concat "Toggle %s on or off. Interactively, with no prefix argument, toggle the mode. With universal prefix ARG turn mode on. With zero or negative ARG turn mode off. \\{%s}") pretty-name keymap-sym)) ;; Use `toggle' rather than (if ,mode 0 1) so that using ;; repeat-command still does the toggling correctly. (interactive (list (or current-prefix-arg 'toggle))) ;; XEmacs addition: save the old mode (let ((old-mode ,mode)) (setq ,mode (cond ((eq arg 'toggle) (not ,mode)) (arg (or (listp arg);; XEmacs addition: C-u alone (> (prefix-numeric-value arg) 0))) (t (if (null ,mode) t (message "Toggling %s off; better pass an explicit argument." ',mode) nil)))) ,＠body ;; The on/off hooks are here for backward compatibility only. ;; The on/off hooks are here for backward compatibility only. ;; XEmacs change: check mode before running hooks (and ,hook (not (equal old-mode ,mode)) (run-hooks ',hook)) (and ,hook-on ,mode (run-hooks ',hook-on)) (and ,hook-off (not ,mode) (run-hooks ',hook-off))) (if (interactive-p) (progn ,(if globalp `(customize-mark-as-set ',mode)) (message ,(format "%s %%sabled" pretty-name) (if ,mode "en" "dis")))) (force-mode-line-update) ;; Return the new setting. ,mode) ;; Autoloading an easy-mmode-define-minor-mode autoloads ;; everything up-to-here. ;; ;; XEmacs change: XEmacs does not support :autoload-end. On the other ;; hand, I don't see why we need to support it. An autoload cookie ;; just before a (define-minor-mode foo) form will generate an autoload ;; form for the file with name foo. But that's exactly right, since ;; the defun created just above here has the name foo. There are no ;; other top-level forms created above here by the macro, so we're done. ;; ;;:autoload-end ;; The toggle's hook. (defcustom ,hook nil ,(format "Hook run at the end of function `%s'." mode-name) ,＠group :type 'hook) ;; XEmacs addition: declare the on and off hooks also (defcustom ,hook-on nil ,(format "Hook to run when entering %s." mode-name) :group ,(cadr group) :type 'hook) (defcustom ,hook-off nil ,(format "Hook to run when exiting %s." mode-name) :group ,(cadr group) :type 'hook) ;; Define the minor-mode keymap. ,(unless (symbolp keymap) ;nil is also a symbol. `(defvar ,keymap-sym (let ((m ,keymap)) (cond ((keymapp m) m) ((listp m) (easy-mmode-define-keymap m)) (t (error "Invalid keymap %S" ,keymap)))) ,(format "Keymap for `%s'." mode-name))) (add-minor-mode ',mode ',lighter ,(if keymap keymap-sym `(if (boundp ',keymap-sym) (symbol-value ',keymap-sym))) ;; XEmacs change: supply the AFTER and TOGGLE-FUN args t ',mode) ;; If the mode is global, call the function according to the default. ,(if globalp `(if (and load-file-name (not (equal ,init-value ,mode)) ;; XEmacs addition: (not purify-flag)) (eval-after-load load-file-name '(,mode (if ,mode 1 -1)))))))) ;;; ;;; make global minor mode ;;; ;;;###no-autoload (defmacro easy-mmode-define-global-mode (global-mode mode turn-on &rest keys) "Make GLOBAL-MODE out of the buffer-local minor MODE. TURN-ON is a function that will be called with no args in every buffer and that should try to turn MODE on if applicable for that buffer. KEYS is a list of CL-style keyword arguments: :group to specify the custom group." (let* ((global-mode-name (symbol-name global-mode)) (pretty-name (easy-mmode-pretty-mode-name mode)) (pretty-global-name (easy-mmode-pretty-mode-name global-mode)) (group nil) (extra-args nil) (buffers (intern (concat global-mode-name "-buffers"))) (cmmh (intern (concat global-mode-name "-cmmh")))) ;; Check keys. (while (keywordp (car keys)) (case (pop keys) (:extra-args (setq extra-args (pop keys))) (:group (setq group (nconc group (list :group (pop keys))))) (t (setq keys (cdr keys))))) (unless group ;; We might as well provide a best-guess default group. (setq group `(:group ',(or (custom-current-group) (intern (replace-regexp-in-string "-mode\\'" "" (symbol-name mode))))))) `(progn ;; The actual global minor-mode (define-minor-mode ,global-mode ,(format "Toggle %s in every buffer. With prefix ARG, turn %s on if and only if ARG is positive. %s is actually not turned on in every buffer but only in those in which `%s' turns it on." pretty-name pretty-global-name pretty-name turn-on) :global t :extra-args ,extra-args ,＠group ;; Setup hook to handle future mode changes and new buffers. (if ,global-mode ;; XEmacs: find-file-hooks not find-file-hook (progn (add-hook 'find-file-hooks ',buffers) (add-hook 'change-major-mode-hook ',cmmh)) (remove-hook 'find-file-hooks ',buffers) (remove-hook 'change-major-mode-hook ',cmmh)) ;; Go through existing buffers. (dolist (buf (buffer-list)) (with-current-buffer buf (if ,global-mode (,turn-on) (when ,mode (,mode -1)))))) ;; TODO: XEmacs does not support :autoload-end ;; Autoloading easy-mmode-define-global-mode ;; autoloads everything up-to-here. :autoload-end ;; List of buffers left to process. (defvar ,buffers nil) ;; The function that calls TURN-ON in each buffer. (defun ,buffers () (remove-hook 'post-command-hook ',buffers) (while ,buffers (let ((buf (pop ,buffers))) (when (buffer-live-p buf) (with-current-buffer buf (,turn-on)))))) (put ',buffers 'definition-name ',global-mode) ;; The function that catches kill-all-local-variables. (defun ,cmmh () (add-to-list ',buffers (current-buffer)) (add-hook 'post-command-hook ',buffers)) (put ',cmmh 'definition-name ',global-mode)))) ;;; ;;; easy-mmode-defmap ;;; (if (fboundp 'set-keymap-parents) (defalias 'easy-mmode-set-keymap-parents 'set-keymap-parents) (defun easy-mmode-set-keymap-parents (m parents) (set-keymap-parent m (cond ((not (consp parents)) parents) ((not (cdr parents)) (car parents)) (t (let ((m (copy-keymap (pop parents)))) (easy-mmode-set-keymap-parents m parents) m)))))) ;;;###no-autoload (defun easy-mmode-define-keymap (bs &optional name m args) "Return a keymap built from bindings BS. BS must be a list of (KEY . BINDING) where KEY and BINDINGS are suitable for `define-key'. Optional NAME is passed to `make-sparse-keymap'. Optional map M can be used to modify an existing map. ARGS is a list of additional keyword arguments." (let (inherit dense ;suppress ) (while args (let ((key (pop args)) (val (pop args))) (case key (:name (setq name val)) (:dense (setq dense val)) (:inherit (setq inherit val)) (:group) ;;((eq key :suppress) (setq suppress val)) (t (message "Unknown argument %s in defmap" key))))) (unless (keymapp m) (setq bs (append m bs)) (setq m (if dense (make-keymap name) (make-sparse-keymap name)))) (dolist (b bs) (let ((keys (car b)) (binding (cdr b))) (dolist (key (if (consp keys) keys (list keys))) (cond ((symbolp key) (substitute-key-definition key binding m global-map)) ((null binding) (unless (keymapp (lookup-key m key)) (define-key m key binding))) ((let ((o (lookup-key m key))) (or (null o) (numberp o) (eq o 'undefined))) (define-key m key binding)))))) (cond ((keymapp inherit) (set-keymap-parent m inherit)) ((consp inherit) (easy-mmode-set-keymap-parents m inherit))) m)) ;;;###no-autoload (defmacro easy-mmode-defmap (m bs doc &rest args) `(defconst ,m (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args)) ,doc)) ;;; ;;; easy-mmode-defsyntax ;;; (defun easy-mmode-define-syntax (css args) (let ((st (make-syntax-table (plist-get args :copy))) (parent (plist-get args :inherit))) (dolist (cs css) (let ((char (car cs)) (syntax (cdr cs))) (if (sequencep char) (mapcar (lambda (c) (modify-syntax-entry c syntax st)) char) (modify-syntax-entry char syntax st)))) ;; XEmacs change: we do not have set-char-table-parent (if parent (derived-mode-merge-syntax-tables (if (symbolp parent) (symbol-value parent) parent) st)) st)) ;;;###no-autoload (defmacro easy-mmode-defsyntax (st css doc &rest args) "Define variable ST as a syntax-table. CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)." `(progn (autoload 'easy-mmode-define-syntax "easy-mmode") (defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) ,doc))) ;;; ;;; easy-mmode-define-navigation ;;; ;; XEmacs change: autoload ;;;###no-autoload (defmacro easy-mmode-define-navigation (base re &optional name endfun) "Define BASE-next and BASE-prev to navigate in the buffer. RE determines the places the commands should move point to. NAME should describe the entities matched by RE. It is used to build the docstrings of the two functions. BASE-next also tries to make sure that the whole entry is visible by searching for its end (by calling ENDFUN if provided or by looking for the next entry) and recentering if necessary. ENDFUN should return the end position (with or without moving point)." (let* ((base-name (symbol-name base)) (prev-sym (intern (concat base-name "-prev"))) (next-sym (intern (concat base-name "-next")))) (unless name (setq name (symbol-name base-name))) `(progn (add-to-list 'debug-ignored-errors ,(concat "^No \$previous\\|next\$ " (regexp-quote name))) (defun ,next-sym (&optional count) ,(format "Go to the next COUNT'th %s." name) (interactive) (unless count (setq count 1)) (if (< count 0) (,prev-sym (- count)) (if (looking-at ,re) (incf count)) (if (not (re-search-forward ,re nil t count)) (if (looking-at ,re) (goto-char (or ,(if endfun `(,endfun)) (point-max))) (error ,(format "No next %s" name))) (goto-char (match-beginning 0)) (when (and (eq (current-buffer) (window-buffer (selected-window))) (interactive-p)) (let ((endpt (or (save-excursion ,(if endfun `(,endfun) `(re-search-forward ,re nil t 2))) (point-max)))) ;; XEmacs change: versions < 21.5.16 have a ;; pos-visible-in-window-p that takes only 2 parameters (unless (if (eq (function-max-args #'pos-visible-in-window-p) 2) (pos-visible-in-window-p endpt nil) (pos-visible-in-window-p endpt nil t)) (recenter '(0)))))))) (defun ,prev-sym (&optional count) ,(format "Go to the previous COUNT'th %s" (or name base-name)) (interactive) (unless count (setq count 1)) (if (< count 0) (,next-sym (- count)) (unless (re-search-backward ,re nil t count) (error ,(format "No previous %s" name)))))))) (provide 'easy-mmode) ;;; easy-mmode.el ends here 1.1 XEmacs/xemacs/lisp/regexp-opt.el Index: regexp-opt.el =================================================================== ;;; regexp-opt.el --- generate efficient regexps to match strings ;; Copyright (C) 1994,95,96,97,98,99,2000 Free Software Foundation, Inc. ;; Author: Simon Marshall <simon(a)gnu.org> ;; Maintainer: FSF ;; Keywords: strings, regexps, extensions ;; Modified by Karl M. Hegbloom Sep. 1997 to support the new regexp syntax ;; with shy groups. (benchmarks pending) ;; This file is part of XEmacs. ;; XEmacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; XEmacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: ;; The "opt" in "regexp-opt" stands for "optim\$al\\|i\\(se\\|ze\$\\)". ;; ;; This package generates a regexp from a given list of strings (which matches ;; one of those strings) so that the regexp generated by: ;; ;; (regexp-opt strings) ;; ;; is equivalent to, but more efficient than, the regexp generated by: ;; ;; (mapconcat 'regexp-quote strings "\\|") ;; ;; For example: ;; ;; (let ((strings '("cond" "if" "when" "unless" "while" ;; "let" "let*" "progn" "prog1" "prog2" ;; "save-restriction" "save-excursion" "save-window-excursion" ;; "save-current-buffer" "save-match-data" ;; "catch" "throw" "unwind-protect" "condition-case"))) ;; (concat "(" (regexp-opt strings t) "\\>")) ;; ;; => "(\$?:c\\(?:atch\\|ond\\(?:ition-case\$?\\)\\|if\\|let\\*?\\|prog[12n]\\|save-\$?:current-buffer\\|excursion\\|match-data\\|restriction\\|window-excursion\$\\|throw\\|un\$?:less\\|wind-protect\$\\|wh\$?:en\\|ile\$\\)\\>" ;; ;; ;; (let ((strings '("cond" "if" "when" "unless" "while" ;; "let" "let*" "progn" "prog1" "prog2" ;; "save-restriction" "save-excursion" "save-window-excursion" ;; "save-current-buffer" "save-match-data" ;; "catch" "throw" "unwind-protect" "condition-case"))) ;; (concat "(" (regexp-opt strings t t) "\\>")) ;; ^ ;; => "(\$c\\(atch\\|ond\\(ition-case\$?\\)\\|if\\|let\\*?\\|prog[12n]\\|save-\$current-buffer\\|excursion\\|match-data\\|restriction\\|window-excursion\$\\|throw\\|un\$less\\|wind-protect\$\\|wh\$en\\|ile\$\\)\\>" ;; ;; ;; Searching using the above example `regexp-opt' regexp takes approximately ;; two-thirds of the time taken using the equivalent `mapconcat' regexp. ;; Since this package was written to produce efficient regexps, not regexps ;; efficiently, it is probably not a good idea to in-line too many calls in ;; your code, unless you use the following trick with `eval-when-compile': ;; ;; (defvar definition-regexp ;; (eval-when-compile ;; (concat "^(" ;; (regexp-opt '("defun" "defsubst" "defmacro" "defalias" ;; "defvar" "defconst") t) ;; "\\>"))) ;; ;; The `byte-compile' code will be as if you had defined the variable thus: ;; ;; (defvar definition-regexp ;; "^(\$def\\(alias\\|const\\|macro\\|subst\\|un\\|var\$\\)\\>") ;; ;; Note that if you use this trick for all instances of `regexp-opt' and ;; `regexp-opt-depth' in your code, regexp-opt.el would only have to be loaded ;; at compile time. But note also that using this trick means that should ;; regexp-opt.el be changed, perhaps to fix a bug or to add a feature to ;; improve the efficiency of `regexp-opt' regexps, you would have to recompile ;; your code for such changes to have effect in your code. ;; Originally written for font-lock.el, from an idea from Stig's hl319.el, with ;; thanks for ideas also to Michael Ernst, Bob Glickstein and Dan Nicolaescu. ;; Please don't tell me that it doesn't produce optimal regexps; I know that ;; already. For example, the above explanation for the meaning of "opt" would ;; be more efficient as "optim\$al\\|i[sz]e\$", but this requires complex ;; forward looking. But (ideas or) code to improve things (are) is welcome. ;;; Code: ;;;###autoload (defun regexp-opt (strings &optional paren non-shy) "Return a regexp to match a string in STRINGS. Each string should be unique in STRINGS and should not contain any regexps, quoted or not. If optional PAREN is non-nil, ensure that the returned regexp is enclosed by at least one regexp match grouping construct. If optional NON-SHY is non nil, the inner groupings will use \"\\\$ \\\$\" grouping, rather than the default \"\\\$?: \\\$\" 'shy', or non-match-capturing groups. The returned regexp is typically more efficient than the equivalent regexp: (let ((open-paren (if PAREN \"\\\$\" \"\")) (close-paren (if PAREN \"\\\$\" \"\"))) (concat open-paren (mapconcat 'regexp-quote STRINGS \"\\\\|\") close-paren)) but typically contains more regexp grouping constructs. Use `regexp-opt-depth' to count them. If PAREN is `words', then the resulting regexp is additionally surrounded by \\=\\< and \\>." (save-match-data ;; Recurse on the sorted list. (let* ((max-lisp-eval-depth (* 1024 1024)) (completion-ignore-case nil) (words (eq paren 'words)) (sorted-strings (sort (copy-sequence strings) 'string-lessp)) (re (regexp-opt-group sorted-strings paren nil non-shy))) (if words (concat "\\<" re "\\>") re)))) ;;;###autoload (defun regexp-opt-depth (regexp &optional count-shy-groups-too) "Return the depth of REGEXP. This means the number of regexp grouping constructs (parenthesised expressions) in REGEXP, not counting the \"\\\$?: \\\$\" non-match-capturing groups unless COUNT-SHY-GROUPS-TOO is non-nil. See `regexp-opt'." (save-match-data ;; Hack to signal an error if REGEXP does not have balanced parentheses. (string-match regexp "") ;; Count the number of open parentheses in REGEXP. (let ((max (1- (length regexp))) (count 0) start) (while (string-match "\\\$" regexp start) (setq start (match-end 0)) (when (or count-shy-groups-too (not (string= (substring regexp start (min (+ start 2) max)) "?:"))) (setq count (1+ count)))) count))) ;;; Workhorse functions. (eval-when-compile (require 'cl)) (unless (fboundp 'make-bool-vector) (defalias 'make-bool-vector 'make-vector)) (defun regexp-opt-group (strings &optional paren lax non-shy) "Return a regexp to match a string in STRINGS. If PAREN non-nil, output regexp parentheses around returned regexp. If LAX non-nil, don't output parentheses if it doesn't require them. If NON-SHY non-nil, don't use \\(?: \$ shy groups, use match capturing ones. Merges keywords to avoid backtracking in Emacs' regexp matcher. The basic idea is to find the shortest common prefix, remove it and recurse. If there is no prefix, we divide the list into two so that $at least) one half will have at least a one-character common prefix. Also we delay the addition of grouping parenthesis as long as possible until we're sure we need them, and try to remove one-character sequences so we can use character sets rather than grouping parenthesis." (let* ((open-group (cond ((and paren non-shy) "\\(") (paren "\\(?:") (t ""))) (close-group (if paren "\$" "")) (open-charset (if lax "" open-group)) (close-charset (if lax "" close-group))) (cond ;; ;; If there are no strings, just return the empty string. ((= (length strings) 0) "") ;; ;; If there is only one string, just return it. ((= (length strings) 1) (if (= (length (car strings)) 1) (concat open-charset (regexp-quote (car strings)) close-charset) (concat open-group (regexp-quote (car strings)) close-group))) ;; ;; If there is an empty string, remove it and recurse on the rest. ((= (length (car strings)) 0) (concat open-charset (regexp-opt-group (cdr strings) t t non-shy) "?" close-charset)) ;; ;; If all are one-character strings, just return a character set. ((= (length strings) (apply '+ (mapcar 'length strings))) (concat open-charset (regexp-opt-charset strings) close-charset)) ;; ;; We have a list of different length strings. (t (let ((prefix (try-completion "" (mapcar 'list strings))) (letters (let ((completion-regexp-list '("^.$"))) (all-completions "" (mapcar 'list strings))))) (cond ;; ;; If there is a common prefix, remove it and recurse on the suffixes. ((> (length prefix) 0) (let* ((length (length prefix)) (suffixes (mapcar (lambda (s) (substring s length)) strings))) (concat open-group (regexp-quote prefix) (regexp-opt-group suffixes t t non-shy) close-group))) ;; ;; If there are several one-character strings, remove them and recurse ;; on the rest (first so the final regexp finds the longest match). ((> (length letters) 1) (let ((rest (let ((completion-regexp-list '("^..+$"))) (all-completions "" (mapcar 'list strings))))) (concat open-group (regexp-opt-group rest nil nil non-shy) "\\|" (regexp-opt-charset letters) close-group))) ;; ;; Otherwise, divide the list into those that start with a particular ;; letter and those that do not, and recurse on them. (t (let* ((char (substring (car strings) 0 1)) (half1 (all-completions char (mapcar 'list strings))) (half2 (nthcdr (length half1) strings))) (concat open-group (regexp-opt-group half1 nil nil non-shy) "\\|" (regexp-opt-group half2 nil nil non-shy) close-group))))))))) (defun regexp-opt-charset (chars) ;; ;; Return a regexp to match a character in CHARS. ;; ;; The basic idea is to find character ranges. Also we take care in the ;; position of character set meta characters in the character set regexp. ;; (let* ((charwidth 256) ; Yeah, right. ;; XEmacs: use bit-vectors instead of bool-vectors (charmap (make-bit-vector charwidth 0)) (charset "") (bracket "") (dash "") (caret "")) ;; ;; Make a character map but extract character set meta characters. (dolist (char (mapcar 'string-to-char chars)) (case char (?\] (setq bracket "]")) (?^ (setq caret "^")) (?- (setq dash "-")) (otherwise ;; XEmacs: 1 (aset charmap char 1)))) ;; ;; Make a character set from the map using ranges where applicable. (dotimes (char charwidth) (let ((start char)) (while (and (< char charwidth) ;; XEmacs: (not (zerop ...)) (not (zerop (aref charmap char)))) (incf char)) (cond ((> char (+ start 3)) (setq charset (format "%s%c-%c" charset start (1- char)))) ((> char start) (setq charset (format "%s%c" charset (setq char start))))))) ;; ;; Make sure a caret is not first and a dash is first or last. (if (and (string-equal charset "") (string-equal bracket "")) (concat "[" dash caret "]") (concat "[" bracket charset caret dash "]")))) (provide 'regexp-opt) ;;; regexp-opt.el ends here 1.784 +13 -29 XEmacs/xemacs/src/ChangeLog (In the diff below, changes in quantity of whitespace are not shown.) Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/ChangeLog,v retrieving revision 1.783 retrieving revision 1.784 diff -u -b -r1.783 -r1.784 --- ChangeLog 2005/02/03 05:03:43 1.783 +++ ChangeLog 2005/02/03 07:11:26 1.784 ＠＠ -1,18 +1,5 ＠＠ 2005-02-02 Ben Wing <ben(a)xemacs.org> - * menubar.c: - * menubar.c (Fcompare_menu_text): - New fun to compare menu itext as if the two were normalized. - - * menubar.c (Fnormalize_menu_text): - * menubar.c (syms_of_menubar): - Rename; there are no external callers of this function. - Remove unneeded BUFFER argument. Don't downcase. - (This will be done in compare-menu-text.) - Document that return value may be same string. - -2005-02-02 Ben Wing <ben(a)xemacs.org> - * lread.c: * lread.c (check_if_suppressed): * lread.c (Fload_internal): ＠＠ -20,28 +7,25 ＠＠ * lread.c (readevalloop): * lread.c (syms_of_lread): * lread.c (vars_of_lread): - * menubar.c: - * menubar.c (Fcompare_menu_text): - * menubar.c (Fnormalize_menu_text): - * menubar.c (syms_of_menubar): - * menubar.c (vars_of_menubar): - -2004-11-09 Ben Wing <ben(a)xemacs.org> - * lisp.h: - - * lread.c: - * lread.c (check_if_suppressed): - * lread.c (Fload_internal): - * lread.c (locate_file_in_directory_mapper): - * lread.c (readevalloop): - * lread.c (syms_of_lread): - * lread.c (vars_of_lread): Remove undeeded Vload_file_name_internal_the_purecopy, Qload_file_name -- use internal_bind_lisp_object instead of specbind. Add load-suppress-alist. + +2005-02-02 Ben Wing <ben(a)xemacs.org> + + * menubar.c: + * menubar.c (Fcompare_menu_text): + New fun to compare menu itext as if the two were normalized. + + * menubar.c (Fnormalize_menu_text): + * menubar.c (syms_of_menubar): + Rename; there are no external callers of this function. + Remove unneeded BUFFER argument. Don't downcase. + (This will be done in compare-menu-text.) + Document that return value may be same string. 2003-02-15 Ben Wing <ben(a)xemacs.org> 1.74 +69 -17 XEmacs/xemacs/src/lread.c (In the diff below, changes in quantity of whitespace are not shown.) Index: lread.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/lread.c,v retrieving revision 1.73 retrieving revision 1.74 diff -u -b -r1.73 -r1.74 --- lread.c 2005/01/24 23:34:02 1.73 +++ lread.c 2005/02/03 07:11:27 1.74 ＠＠ -59,8 +59,8 ＠＠ #endif Lisp_Object Qvariable_domain; /* I18N3 */ Lisp_Object Vvalues, Vstandard_input, Vafter_load_alist; -Lisp_Object Qcurrent_load_list; -Lisp_Object Qload, Qload_file_name, Qload_internal, Qfset; +Lisp_Object Vload_suppress_alist; +Lisp_Object Qload, Qload_internal, Qfset; /* Hash-table that maps directory names to hashes of their contents. */ static Lisp_Object Vlocate_file_hash_table; ＠＠ -118,8 +118,6 ＠＠ our #$ checks are reliable. */ Lisp_Object Vload_file_name_internal; -Lisp_Object Vload_file_name_internal_the_purecopy; - /* Function to use for reading, in `load' and friends. */ Lisp_Object Vload_read_function; ＠＠ -340,6 +338,50 ＠＠ return Qnil; } +/* Check if NONRELOC/RELOC (an absolute filename) is suppressed according + to load-suppress-alist. */ +static int +check_if_suppressed (Ibyte *nonreloc, Lisp_Object reloc) +{ + Bytecount len; + + if (!NILP (reloc)) + { + nonreloc = XSTRING_DATA (reloc); + len = XSTRING_LENGTH (reloc); + } + else + len = qxestrlen (nonreloc); + + if (len >= 4 && !qxestrcmp_ascii (nonreloc + len - 4, ".elc")) + len -= 4; + else if (len >= 3 && !qxestrcmp_ascii (nonreloc + len - 3, ".el")) + len -= 3; + + EXTERNAL_LIST_LOOP_2 (acons, Vload_suppress_alist) + { + if (CONSP (acons) && STRINGP (XCAR (acons))) + { + Lisp_Object name = XCAR (acons); + if (XSTRING_LENGTH (name) == len && + !memcmp (XSTRING_DATA (name), nonreloc, len)) + { + struct gcpro gcpro1; + Lisp_Object val; + + GCPRO1 (reloc); + val = Feval (XCDR (acons)); + UNGCPRO; + + if (!NILP (val)) + return 1; + } + } + } + + return 0; +} + /* The plague is coming. Ring around the rosy, pocket full of posy, ＠＠ -689,12 +731,11 ＠＠ internal_bind_lisp_object (&Vload_descriptor_list, Fcons (make_int (fd), Vload_descriptor_list)); internal_bind_lisp_object (&Vload_file_name_internal, found); - internal_bind_lisp_object (&Vload_file_name_internal_the_purecopy, Qnil); /* this is not a simple internal_bind. */ record_unwind_protect (load_force_doc_string_unwind, Vload_force_doc_string_list); Vload_force_doc_string_list = Qnil; - specbind (Qload_file_name, found); + internal_bind_lisp_object (&Vload_file_name, found); #ifdef I18N3 /* set it to nil; a call to #'domain will set it. */ internal_bind_lisp_object (&Vfile_domain, Qnil); ＠＠ -818,6 +859,9 ＠＠ requirements. Allowed symbols are `exists', `executable', `writable', and `readable'. If MODE is nil, it defaults to `readable'. +Filenames are checked against `load-suppress-alist' to determine if they +should be ignored. + `locate-file' keeps hash tables of the directories it searches through, in order to speed things up. It tries valiantly to not get confused in the face of a changing and unpredictable environment, but can occasionally ＠＠ -1024,6 +1068,8 ＠＠ if (closure->fd >= 0) { + if (!check_if_suppressed (fn, Qnil)) + { /* We succeeded; return this descriptor and filename. */ if (closure->storeptr) *closure->storeptr = build_intstring (fn); ＠＠ -1031,6 +1077,7 ＠＠ return 1; } } + } /* Keep mapping. */ return 0; } ＠＠ -1178,7 +1225,7 ＠＠ just look for one for which access(file,MODE) succeeds. In this case, returns a nonnegative value on success. On failure, returns -1. - If STOREPTR is nonzero, it points to a slot where the name of + If STOREPTR is non-nil, it points to a slot where the name of the file actually found should be stored as a Lisp string. Nil is stored there on failure. ＠＠ -1377,7 +1424,7 ＠＠ READCHARFUN (which can be a stream) to Lisp. --hniksic */ /*specbind (Qstandard_input, readcharfun);*/ - specbind (Qcurrent_load_list, Qnil); + internal_bind_lisp_object (&Vcurrent_load_list, Qnil); #ifdef COMPILED_FUNCTION_ANNOTATION_HACK Vcurrent_compiled_function_annotation = Qnil; ＠＠ -3072,9 +3119,7 ＠＠ DEFSYMBOL (Qstandard_input); DEFSYMBOL (Qread_char); - DEFSYMBOL (Qcurrent_load_list); DEFSYMBOL (Qload); - DEFSYMBOL (Qload_file_name); DEFSYMBOL (Qload_internal); DEFSYMBOL (Qfset); ＠＠ -3141,6 +3186,16 ＠＠ Non-nil iff inside of `load'. */ ); + DEFVAR_LISP ("load-suppress-alist", &Vload_suppress_alist /* +An alist of expressions controlling whether particular files can be loaded. +Each element looks like (FILENAME EXPR). +FILENAME should be a full pathname, but without the .el suffix. +When `load' is run and is about to load the specified file, it evaluates +the form to determine if the file can be loaded. +This variable is normally initialized automatically. +*/ ); + Vload_suppress_alist = Qnil; + DEFVAR_LISP ("after-load-alist", &Vafter_load_alist /* An alist of expressions to be evalled when particular files are loaded. Each element looks like (FILENAME FORMS...). ＠＠ -3254,9 +3309,6 ＠＠ Vload_file_name_internal = Qnil; staticpro (&Vload_file_name_internal); - - Vload_file_name_internal_the_purecopy = Qnil; - staticpro (&Vload_file_name_internal_the_purecopy); #ifdef COMPILED_FUNCTION_ANNOTATION_HACK Vcurrent_compiled_function_annotation = Qnil; 1.123 +1 -2 XEmacs/xemacs/src/lisp.h (In the diff below, changes in quantity of whitespace are not shown.) Index: lisp.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/lisp.h,v retrieving revision 1.122 retrieving revision 1.123 diff -u -b -r1.122 -r1.123 --- lisp.h 2005/01/31 19:29:49 1.122 +++ lisp.h 2005/02/03 07:11:28 1.123 ＠＠ -5294,8 +5294,7 ＠＠ extern Lisp_Object Vinvocation_directory, Vinvocation_name; extern Lisp_Object Vlast_command, Vlast_command_char; extern Lisp_Object Vlast_command_event, Vlast_input_event; -extern Lisp_Object Vload_file_name_internal; -extern Lisp_Object Vload_file_name_internal_the_purecopy, Vload_history; +extern Lisp_Object Vload_file_name_internal, Vload_history; extern Lisp_Object Vload_path, Vmark_even_if_inactive, Vmenubar_configuration; extern Lisp_Object Vminibuf_preprompt, Vminibuf_prompt, Vminibuffer_zero; extern Lisp_Object Vmodule_directory, Vmswindows_downcase_file_names;

1 participants
0 comments

CVS update: MODIFIED: man ... 20 years, 2 months

CVS Monitor

User: stephent Date: 05/02/03 07:14:41 Modified: xemacs/man ChangeLog beta.texi Log: fix build, minor improvements <87651a41d4.fsf(a)tleepslib.sk.tsukuba.ac.jp> Revision Changes Path 1.285 +26 -0 XEmacs/xemacs/man/ChangeLog (In the diff below, changes in quantity of whitespace are not shown.) Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/man/ChangeLog,v retrieving revision 1.284 retrieving revision 1.285 diff -u -b -r1.284 -r1.285 --- ChangeLog 2005/01/31 20:08:47 1.284 +++ ChangeLog 2005/02/03 06:14:40 1.285 ＠＠ -1,3 +1,29 ＠＠ +2005-02-03 Stephen J. Turnbull <stephen(a)xemacs.org> + + * beta.texi: Update Copyright. Add pointer comment. + + (New packages): Remove personal names, point at jobs.html + instead. + + (Syncing with GNU Emacs): Change "don't assume Mule" to + "conditionalize Mule dependencies correctly". RMS stroking: use + "GNU", not "FSF", in sync notices. + +2005-02-02 Robert Delius Royar <xemacs(a)frinabulax.org> + + * beta.texi (Top): + Add reference to Index in catalog to prevent + errors compiling with GNU makeinfo 4.5. + + * beta.texi (Syncing with GNU Emacs): + Add forward reference to Index in next node to prevent + errors compiling with GNU makeinfo 4.5. + + * beta.texi (Index): + Add backward reference to Syncing with GNU Emacs to + replace obsolete reference to Defining Variables to + prevent errors compiling with GNU makeinfo 4.5. + 2005-01-31 Ben Wing <ben(a)xemacs.org> * xemacs/help.texi (Misc Help): 1.2 +23 -11 XEmacs/xemacs/man/beta.texi (In the diff below, changes in quantity of whitespace are not shown.) Index: beta.texi =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/man/beta.texi,v retrieving revision 1.1 retrieving revision 1.2 diff -u -b -r1.1 -r1.2 --- beta.texi 2005/01/31 20:08:47 1.1 +++ beta.texi 2005/02/03 06:14:40 1.2 ＠＠ -1,5 +1,10 ＠＠ \input texinfo ＠c -*-texinfo-*- +＠c This file is in Texinfo format. +＠c If for some reason you do not have the formatted version available, +＠c this file is more or less readable as plain text. +＠c Skip to the line beginning "＠node Introduction". + ＠c %**start of header ＠setfilename ../info/beta.info ＠settitle Info on beta versions of XEmacs ＠＠ -14,6 +19,7 ＠＠ This file describes info relevant to beta versions of XEmacs. Copyright ＠copyright{} 2005 Ben Wing. +Copyright ＠copyright{} 2005 Free Software Foundation, Inc. This file is part of XEmacs. ＠＠ -80,6 +86,7 ＠＠ * Compiling Beta XEmacs:: * Packages:: * Improving XEmacs:: +* Index:: ＠detailmenu --- The Detailed Node Listing --- ＠＠ -691,7 +698,7 ＠＠ $ make install ＠end example -＠node Improving XEmacs, , Packages, Top +＠node Improving XEmacs, Index, Packages, Top ＠chapter Improving XEmacs ＠menu ＠＠ -878,12 +885,12 ＠＠ rapid acceptance of the package. For help in creating new packages, see the (rather sparse) discussions -in the XEmacs User's Guide and the Lisp Reference Manual. The XEmacs -Package Release Engineer (Ville Skyttä ＠uref{mailto:scop＠＠xemacs.org} -is currently serving with Norbert Koch ＠uref{mailto:viteno＠＠xemacs.org} -assisting; Steve Youngs ＠uref{mailto:youngs＠＠xemacs.org} and Stephen -Turnbull ＠uref{mailto:stephen＠＠xemacs.org} also can help) are the most -likely sources of advice. +in the XEmacs User's Guide and the Lisp Reference Manual. The +participants in the XEmacs Beta mailing list +＠uref{mailto:xemacs-beta＠＠xemacs.org} and the XEmacs Package Release +Engineer are the most likely sources of advice. See +＠uref{http://www.xemacs.org/Develop/jobs.html#package,jobs.html} for +current information about package release engineers. ＠node Syncing with GNU Emacs, , New packages, Large contributions ＠subsection Syncing with GNU Emacs ＠＠ -897,7 +904,9 ＠＠＠itemize ＠bullet ＠item Recent GNU Emacsen cannot be built without Mule, but XEmacs can. -Make sure your changes do not assume the presence of Mule. +Make sure that changes that depend on the presence of Mule are +appropriately conditionalized, with ＠samp{#ifdef MULE} in C code and +with ＠samp{(featurep 'mule)} in Lisp. ＠item GNU Emacs nomenclature often differs from that of XEmacs. ＠＠ -913,13 +922,16 ＠＠ purpose, we use comments of the form ＠example -/* Synched up with: FSF 21.3 by Stephen Turnbull */ +/* Synched up with: GNU 21.3 by Stephen Turnbull */ ＠end example in the source file itself, as the last element of the prefatory material (copyright notice and commentary). Obviously the comment marker needs to be changed to leading semicolons for Lisp, but -otherwise the format is the same. +otherwise the format is the same. (Older sync comments may have ``FSF'' +in place of ``GNU''. They're equally accurate in our opinion, but +Richard Stallman and other GNU developers consider the term ``FSF +Emacs'' ``insulting''. Please use ``GNU'' in new sync comments.) Of course you should note syncing as the purpose in the ChangeLog, too. But entries get buried deep in the ChangeLog file, and may even ＠＠ -938,7 +950,7 ＠＠＠contents ＠c That's all -＠node Index, , Defining Variables, Top +＠node Index, , Improving XEmacs, Top ＠unnumbered Index ＠printindex cp

1 participants
0 comments

CVS update: MODIFIED: lisp ... 20 years, 2 months

CVS Monitor

User: ben Date: 05/02/03 06:26:45 Modified: xemacs/lisp ChangeLog behavior.el behavior-defs.el mwheel.el Log: behavior ws #3: behavior updates behavior.el: Major update. Add documentation of how it works. behavior-defs.el: Only define the basic behavior groups here. Move the definitions for particular packages to the appropriate package files. mwheel.el: Add define-behavior for mwheel. Revision Changes Path 1.623 +50 -48 XEmacs/xemacs/lisp/ChangeLog (In the diff below, changes in quantity of whitespace are not shown.) Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/ChangeLog,v retrieving revision 1.622 retrieving revision 1.623 diff -u -b -r1.622 -r1.623 --- ChangeLog 2005/02/03 05:03:36 1.622 +++ ChangeLog 2005/02/03 05:26:39 1.623 ＠＠ -1,5 +1,55 ＠＠ 2005-02-02 Ben Wing <ben(a)xemacs.org> + * behavior.el: + * behavior.el (behavior-group-hash-table): New. + * behavior.el (behavior-override-hash-table): New. + * behavior.el (define-behavior): Removed. + * behavior.el (behavior-group-p): New. + * behavior.el (check-behavior-group): New. + * behavior.el (override-behavior): + * behavior.el (define-behavior-group): + * behavior.el (read-behavior): + * behavior.el (compute-behavior-group-children): New. + * behavior.el (behavior-menu-filter-1): New. + * behavior.el (behavior-menu-filter): New. + Major update. Add documentation of how it works. + + * behavior-defs.el: + * behavior-defs.el (tty): + * behavior-defs.el ('scroll-in-place): Removed. + * behavior-defs.el ('mouse-avoidance): Removed. + * behavior-defs.el ('jka-compr): Removed. + * behavior-defs.el ('efs): Removed. + * behavior-defs.el ('resize-minibuffer): Removed. + * behavior-defs.el ('func-menu): Removed. + * behavior-defs.el ('mwheel): Removed. + * behavior-defs.el ('recent-files): Removed. + * behavior-defs.el ('filladapt): Removed. + * behavior-defs.el ('tty)): New. + * behavior-defs.el ('toolbars)): New. + * behavior-defs.el ('menus)): New. + * behavior-defs.el ('mouse)): New. + * behavior-defs.el ('editing)): New. + * behavior-defs.el ('keyboard)): New. + * behavior-defs.el ('files)): New. + * behavior-defs.el ('games)): New. + * behavior-defs.el ('processes)): New. + * behavior-defs.el ('display)): New. + * behavior-defs.el ('programming)): New. + * behavior-defs.el ('international)): New. + * behavior-defs.el ('buffers-and-windows)): New. + * behavior-defs.el ('internet)): New. + * behavior-defs.el ('compose-mail): New. + Only define the basic behavior groups here. + Move the definitions for particular packages to the + appropriate package files. + + * mwheel.el: + * mwheel.el ('mwheel): New. + Add define-behavior for mwheel. + +2005-02-02 Ben Wing <ben(a)xemacs.org> + * easymenu.el (easy-menu-add): * easymenu.el (easy-menu-remove): * map-ynp.el (map-y-or-n-p): ＠＠ -193,54 +243,6 ＠＠ Major update. Sync with FSF 21.2. Create the ability to make custom-defines files. - * behavior-defs.el: - * behavior-defs.el (tty): - * behavior-defs.el ('scroll-in-place): Removed. - * behavior-defs.el ('mouse-avoidance): Removed. - * behavior-defs.el ('jka-compr): Removed. - * behavior-defs.el ('efs): Removed. - * behavior-defs.el ('resize-minibuffer): Removed. - * behavior-defs.el ('func-menu): Removed. - * behavior-defs.el ('mwheel): Removed. - * behavior-defs.el ('recent-files): Removed. - * behavior-defs.el ('filladapt): Removed. - * behavior-defs.el ('tty)): New. - * behavior-defs.el ('toolbars)): New. - * behavior-defs.el ('menus)): New. - * behavior-defs.el ('mouse)): New. - * behavior-defs.el ('editing)): New. - * behavior-defs.el ('keyboard)): New. - * behavior-defs.el ('files)): New. - * behavior-defs.el ('games)): New. - * behavior-defs.el ('processes)): New. - * behavior-defs.el ('display)): New. - * behavior-defs.el ('programming)): New. - * behavior-defs.el ('international)): New. - * behavior-defs.el ('buffers-and-windows)): New. - * behavior-defs.el ('internet)): New. - * behavior-defs.el ('compose-mail): New. - Only define the basic behavior groups here. - Move the definitions for particular packages to the - appropriate package files. - - * behavior.el: - * behavior.el (behavior-group-hash-table): New. - * behavior.el (behavior-override-hash-table): New. - * behavior.el (define-behavior): Removed. - * behavior.el (behavior-group-p): New. - * behavior.el (check-behavior-group): New. - * behavior.el (override-behavior): - * behavior.el (define-behavior-group): - * behavior.el (read-behavior): - * behavior.el (compute-behavior-group-children): New. - * behavior.el (behavior-menu-filter-1): New. - * behavior.el (behavior-menu-filter): New. - Major update. Add documentation of how it works. - - * mwheel.el: - * mwheel.el ('mwheel): New. - Add define-behavior for mwheel. - * paragraphs.el: * paragraphs.el (paragraphs): New. * paragraphs.el (use-hard-newlines): Removed. 1.5 +349 -22 XEmacs/xemacs/lisp/behavior.el (In the diff below, changes in quantity of whitespace are not shown.) Index: behavior.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/behavior.el,v retrieving revision 1.4 retrieving revision 1.5 diff -u -b -r1.4 -r1.5 --- behavior.el 2003/03/09 02:27:32 1.4 +++ behavior.el 2005/02/03 05:26:40 1.5 ＠＠ -1,6 +1,6 ＠＠ -;;; behavior.el --- consistent interface onto behaviors +;;; behavior.el --- consistent interface onto packages -;; Copyright (C) 2000, 2001, 2002 Ben Wing. +;; Copyright (C) 2000, 2001, 2002, 2003 Ben Wing. ;; Author: Ben Wing ;; Maintainer: XEmacs Development Team ＠＠ -31,13 +31,152 ＠＠ ;;; Commentary: -;; This file will be dumped with XEmacs. +;; This file is dumped with XEmacs. +;; This file is part of the "Behaviors" project and is a work in progress. +;; The purpose of the project is to provide (a) a consistent interface (at +;; the API level) onto the functionality provided by packages, and (b) an +;; easy-to-use user interface for this functionality, something that +;; *really works*. +;; +;; First, what characteristics do/should packages have? (NOTE: In this +;; discussion below, `package' and `behavior' are being used more or less +;; interchangeably. Eventually this will get resolved.) + +;; 1) A file, or one or more file, containing the code of the package. In +;; addition, a "head" file in the case that the package needs to be +;; loaded in order to get its functionality (e.g. "load-to-enable" +;; packages -- an abomination that is tolerated only with severe +;; displeasure). +;; 2) A Lisp name -- a fairly short symbol (2-3 words max), uncapitalized, +;; without use of excessive abbreviation and with words set off by +;; dashes. This should be the same as the name of the topmost custom +;; group associated with the package (see next item), and preferably the +;; same as the common prefix used for variables defined by your package +;; and the name of the head file of the package. +;; 3) Associated custom group listing the settings associated with the package. +;; 4) Enable and disable methods for turning on or off the functionality of +;; the package, if it's amenable to such a model. Most packages are of two +;; types: +;; +;; (a) They add some functionality to XEmacs, which is incorporated +;; into and makes changes to the normal functionality of XEmacs. Once the +;; package is enabled, the user doesn't have to do anything specific for +;; the package to do its thing -- it happens automatically if the user is +;; using the area whose behavior has been changed. These include packages +;; such as `avoid' (which makes the mouse poointer move when the cursor +;; gets too close), EFS (which adds the ability to treat an FTP site as +;; part of the local file system), the packages that supply the +;; mode-specific handling for various files, etc +;; +;; (b) They provide functionality in the form of specific command to be +;; invoked. This can be as simple as the `hippie-expand' command (tries +;; lots of different expansion methods for the text before point, to +;; try and get a result) and as complicated as GNUS or VM. +;; +;; Some packages might provide both -- you can enable them and they +;; incorporate some functionality into the XEmacs base, but while +;; they're enabled they provide certain commands. #### We need some +;; thought here, and case-by-case analysis, to determine if this really +;; makes sense -- can the enable/disable be removed and whatever needs +;; to happen incorporated as part of the command? can the +;; enable/disable just added to the commands? +;; +;; 5) Packages of type (b) just above will have a list of commands that can be +;; run. They should be in standard menubar format -- i.e. just like a +;; submenu, but without the initial string indidicating the name of the +;; menu. +;; 6) Short doc string, for use in a menu item. *NOT* necessarily the same +;; as the documentation for the Custom group, which is often too long. +;; 7) Long documentation. +;; +;; Good package etiquette: +;; +;; +;; -- Never mess with the menu yourself, or try to "cheat" by putting yourself +;; high up in the hierarchy, e.g. at the top-level or directly off a +;; top-level group that expects to contain only groups of groups, not +;; end-level groups. +;; +;; -- Never use the `override-behavior' commands or the like for specifying +;; (in an overriding fashion) the exact appearance of the hierarchies. +;; +;; -- For type (a), with enable/disable methods: +;; +;; (a) Loading the file should NOT DO ANYTHING. Not enable, not add hooks, +;; nothing. +;; (b) Both enable and disable hooks must exist. The disable hook must +;; completely reset the environment to how it was before the package +;; was enabled. This includes restoring the prior bindings for +;; modified key bindings. #### We need some helper function to assist +;; with remembering the old key bindings and putting them back only +;; when new key bindings haven't been made -- but recognize when those +;; new key bondings were attached as a result of loading another +;; package, so that after any order of loading and unloading a series +;; of packages, the original bindings will eventually occur. (Something +;; like `advice' for key definitions.) Replacement of functions should +;; happen through `advice'. +;; +;; We recognize that many packages out there don't follow these precepts at +;; all. Many or most of them are install-only, often happening +;; automatically when the file is loaded. Converting these will be a step +;; at a time: First, redo the latter type so that the initialization code +;; is put into a function and not run automatically upon load. Next step, +;; try to provide some sort of disable. Third step, work on making sure +;; that disable removes *everything* and enable puts it all back. Fourth +;; step, work on properly advising keys and functions. +;; + +;; Comparison/Integration with Custom: + +;; Custom only handles variable settings, and has no concept of standard +;; enable/disable methods for a package, a standard way of specifying +;; package documentation, or a list of commands associated with a package. +;; Also, its groups do not always map very well onto packages and the +;; resulting hierarchy is too big, confusing, difficult-to-navigate, and +;; incoherent. More generally it does not address at all the basic problem +;; that a hierarchy created in a decentralized fashion -- and by a large +;; number of authors, some more competent than others -- will inevitably be +;; incoherent when put together. +;; + +;; In general, ease-of-use was not the overarching goal of Custom. The +;; primary goal of Custom seems to have been to provide a consistent interface +;; and get all the packages to use it. Ease-of-use -- or even following +;; established user-interface standards -- has taken a far-distant second, and +;; appears in many respects to be an afterthought that never had any serious +;; effort investigated into it. +;; +;; The eventual intent of this project is to integrate with custom. The final +;; intent of integration is that this project subsumes Custom completely, +;; making Custom the unified, user-friendly means of controlling XEmacs that +;; has never properly existed. However, that will take a lot of work. For +;; the meantime, the plan is to develop the Behavior subsystem independent of +;; Custom, with ease-of-use as the primary goal, and get it to the point where +;; it encompasses most packages out there, has stabilized its interface, and +;; works well. At that point, we will consider integration with Custom. (Note +;; that the hard part of the Behavior work is not actually behaviorizing the +;; packages, but developing the interface itself.) +;; +;; As for integrating with Custom -- ideally that would mean simply extending +;; defgroup, but that is not really possible given that backward-compatibility +;; would not work -- existing versions of `defgroup' give an error when +;; presented with an unknown keyword. In practice, then, this might mean that +;; a separate `define-behavior' command (or `defpackage', or the like) will +;; still exist. + ;;; Code: ;; Hash table mapping behavior names to property lists, with entries for -;; :short-doc, :require, :enable, and :disable. +;; :group, :custom-group, :short-doc, :require, :enable, :disable, +;; and :commands. (defconst behavior-hash-table (make-hash-table)) +;; Hash table mapping groups to property lists (entries for :group, :children, +;; :short-doc). +(defconst behavior-group-hash-table (make-hash-table)) +;; Hash table with override information for groups. +;; :short-doc). +(defconst behavior-override-hash-table (make-hash-table)) (defvar within-behavior-enabling-disabling nil) ＠＠ -68,37 +207,134 ＠＠ (defvar behavior-history nil "History of entered behaviors.") -(defun define-behavior (name doc-string &rest cl-keys) +(defun behavior-group-p (group) + "Non-nil if GROUP is the name of a valid behavior group." + (not (null (gethash group behavior-group-hash-table)))) + +(defun check-behavior-group (group) + "Verify that GROUP is a valid behavior group, or nil. +Return GROUP if so." + (or (behavior-group-p group) + (error 'invalid-argument "Invalid behavior group" group)) + group) + +(defun* define-behavior (name doc-string &key + group custom-group + (short-doc + (capitalize-string-as-title + (replace-in-string (symbol-name name) "-" " "))) + require enable disable commands + &allow-other-keys) + ;; We allow other keys to allow for the possibility of extensions by + ;; later versions of XEmacs. Packages should be able to support those + ;; extensions without worrying about causing problems with older versions + ;; of XEmacs. "Define a behavior named NAME. DOC-STRING must be specified, a description of what the behavior does when it's enabled and how to further control it (typically through custom variables). Accepted keywords are +:group Symbol naming the behavior group this behavior is within. +:custom-group Symbol naming the custom group containing the options that + can be set in association with this behavior. If not specified, + the custom group with the same name as the behavior will be + used, if it exists. :short-doc A \"pretty\" version of the name, for use in menus. If omitted a prettified name will be generated. :require A single symbol or a list of such symbols, which need to be present at enable time, or will be loaded using `require'. :enable A function of no variables, which turns the behavior on. :disable A function of no variables, which turns the behavior off. +:commands A list of interactive commands that can be invoked in + conjunction with the behavior. These will appear in a submenu + along with the rest of the items for the behavior. Behaviors are assumed to be global, and to take effect immediately; if the underlying package is per-buffer, it may have to scan all existing buffers and frob them. When a behavior is disabled, it should completely go away *everywhere*, as if it were never invoked at all. -The :disable keywords can be missing, although this is considered bad +The :disable keyword can be missing, although this is considered bad practice. In such a case, attempting to disable the behavior will signal -an error unless you use the `force' option." - (cl-parsing-keywords - ((:short-doc (capitalize-string-as-title (replace-in-string - (symbol-name name) "-" " "))) - :require - :enable - :disable) - t - (let ((entry (list :short-doc cl-short-doc :require cl-require - :enable cl-enable :disable cl-disable))) - (puthash name entry behavior-hash-table)))) +an error unless you use the `force' option. + +The :enable keyword can be missing. This is useful for behaviors that +are really a series of related commands without anything semantically +corresponding to \"turning on\" or \"turning off\" the behavior. + +A behavior with no :enable and no :command is possible. This might be +used, for example, by a behavior that encapsulates a series of related +Lisp functions. Such behaviors may be handled specially, e.g. not +displayed in the menus or displayed in a separate location, since they +have no user-invocable behavior." + (let ((entry (list :group (check-behavior-group group) + :custom-group custom-group + :short-doc short-doc :require require + :enable enable :disable disable + :commands commands))) + (puthash name entry behavior-hash-table)) + ;; update the children list of the group we're in (maybe nil). + (unless (member name (getf (gethash group behavior-group-hash-table) + :children)) + (push name (getf (gethash group behavior-group-hash-table) :children)))) + +(defun* override-behavior (name &key + short-doc + group + include + demote-others) + "Override the default properties of a behavior group NAME. +Normally, groups are created and assigned properties by individual packages. +The resulting hierarchy may not make much sense globally. This function +allows the hierarchy and appearance of a group to be specified globally, +and will take precendence over the properties assigned by `define-behavior-group'. This allows a global organization to be imposed on groups, while still allowing for graceful handling of new or unknown groups. + +NAME can be a symbol specifying a group name, or a list of +\(PARENT [...] NAME), where a path from a particular parent is explicitly +given. (This latter form allows the same name to be assigned to more than one +group.) + +Accepted keywords are + +:short-doc A \"pretty\" version of the name, for use in menus. +:group Parent group, if any. Should not be given if the parents are + explicitly specified in NAME. +:include A list of behaviors that are specifically included in this + group, in addition to those that are included by the behaviors + themselves. +:demote-others If non-nil, exclude all behaviors not specified in the :include + list and put them instead (i.e. \"demote\" them) to another group, + usually a subgroup." + (let ((entry (list :group (check-behavior-group group) + :short-doc short-doc + :include include + :demote-others demote-others))) + (puthash name entry behavior-override-hash-table))) + +(defun* define-behavior-group (name &key + (short-doc + (capitalize-string-as-title + (replace-in-string (symbol-name name) "-" + " "))) + group) + "Define a behavior group NAME. + +NAME can be a symbol specifying a group name, or a list of +\(PARENT [...] NAME), where a path from a particular parent is explicitly +given. (This latter form allows the same name to be assigned to more than one +group.) + +Accepted keywords are + +:short-doc A \"pretty\" version of the name, for use in menus. If omitted + a prettified name will be generated. +:group Parent group, if any. Should not be given if the parents are + explicitly specified in NAME." + (let ((entry (list :group (check-behavior-group group) + :short-doc short-doc))) + (puthash name entry behavior-group-hash-table)) + ;; update the children list of the parent (maybe nil). + (push name (getf (gethash group behavior-group-hash-table) :children))) (defun read-behavior (prompt &optional must-match initial-contents history default-value) ＠＠ -119,12 +355,10 ＠＠ behavior-hash-table) (nreverse lis)))) (mapc #'(lambda (aentry) - (setcar aentry (symbol-name - (car aentry)))) + (setcar aentry (symbol-name (car aentry)))) table) table) - nil must-match initial-contents - (or history 'behavior-history) + nil must-match initial-contents (or history 'behavior-history) default-value))) (if (and result (stringp result)) (intern result) ＠＠ -178,6 +412,99 ＠＠ (let ((within-behavior-enabling-disabling t)) (customize-set-variable 'enabled-behavior-list (delq behavior enabled-behavior-list)))))) + +(defun compute-behavior-group-children (group hash) + "Compute the actual children for GROUP and its subgroups. +This takes into account the override information specified." + (let* ((group-plist (gethash group behavior-group-hash-table)) + (override (gethash group behavior-override-hash-table)) + (children (getf group-plist :children))) + ) + ) + +(defun behavior-menu-filter-1 (menu group) + (submenu-generate-accelerator-spec + (let* ( + ;;options + ;;help + (enable + (menu-split-long-menu + (menu-sort-menu + (let ((group-plist (gethash group behavior-group-hash-table))) + (loop for behavior in (getf group-plist :children) + nconc (if (behavior-group-p behavior) + (list + (cons (getf + (gethash behavior behavior-group-hash-table) + :short-doc) + (behavior-menu-filter-1 menu behavior))) + (let* ((plist (gethash behavior behavior-hash-table)) + (commands (getf plist :commands))) + (nconc + (if (getf plist :enable) + `([,(format "%s (%s) [toggle]" + (getf plist :short-doc) + behavior) + (if (memq ',behavior + enabled-behavior-list) + (disable-behavior ',behavior) + (enable-behavior ',behavior)) + :active ,(if (getf plist :disable) t + (not (memq + ',behavior + enabled-behavior-list))) + :style toggle + :selected (memq ',behavior + enabled-behavior-list)])) + (cond ((null commands) nil) + ((and (eq (length commands) 1) + (vectorp (elt commands 0))) + (let ((comm (copy-sequence + (elt commands 0)))) + (setf (elt comm 0) + (format "%s (%s)" + (elt comm 0) behavior)) + (list comm))) + (t (list + (cons (format "%s (%s) Commands" + (getf plist :short-doc) + behavior) + commands))))))))) + )) + ) + ) + enable) + '(?p))) + +(defun behavior-menu-filter (menu) + (append + '(("%_Package Utilities" + ("%_Set Download Site" + ("%_Official Releases" + :filter (lambda (&rest junk) + (menu-split-long-menu + (submenu-generate-accelerator-spec + (package-ui-download-menu))))) + ("%_Pre-Releases" + :filter (lambda (&rest junk) + (menu-split-long-menu + (submenu-generate-accelerator-spec + (package-ui-pre-release-download-menu))))) + ("%_Site Releases" + :filter (lambda (&rest junk) + (menu-split-long-menu + (submenu-generate-accelerator-spec + (package-ui-site-release-download-menu)))))) + "--:shadowEtchedIn" + ["%_Update Package Index" package-get-update-base] + ["%_List and Install" pui-list-packages] + ["U%_pdate Installed Packages" package-get-update-all] + ["%_Help" (Info-goto-node "(xemacs)Packages")]) + "----") + (behavior-menu-filter-1 menu nil))) + +;; Initialize top-level group. +(puthash nil '(:children nil :short-doc "Root") behavior-group-hash-table) (provide 'behavior) 1.5 +22 -470 XEmacs/xemacs/lisp/behavior-defs.el (In the diff below, changes in quantity of whitespace are not shown.) Index: behavior-defs.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/behavior-defs.el,v retrieving revision 1.4 retrieving revision 1.5 diff -u -b -r1.4 -r1.5 --- behavior-defs.el 2002/03/15 07:43:18 1.4 +++ behavior-defs.el 2005/02/03 05:26:41 1.5 ＠＠ -1,6 +1,6 ＠＠ ;;; behavior-defs.el --- definitions of specific behaviors -;; Copyright (C) 2000, 2001, 2002 Ben Wing. +;; Copyright (C) 2000, 2001, 2002, 2003 Ben Wing. ;; Author: Ben Wing ;; Maintainer: XEmacs Development Team ＠＠ -31,475 +31,27 ＠＠ ;;; Commentary: -;; This file will be dumped with XEmacs. +;; This file is dumped with XEmacs. ;;; Code: -(require 'behavior) - -(define-behavior 'scroll-in-place -"This package provides improved vertical scrolling commands for XEmacs. -These new commands offer the following features: - -+ When a scrolling command is executed, XEmacs tries to keep point as - close as possible to its original window position (window line and - column). This is what \"scroll in place\" means: point stays \"in place\" - within the window. (There are times when point must be moved from its - original window position in order to execute the scroll; see below.) - - The variable `scroll-in-place', which is true by default, determines - whether or not the standard XEmacs scrolling commands (`scroll-down', - `scroll-up', `scroll-other-window-down', and `scroll-other-window') use - the \"in place\" features listed here. When `scroll-in-place' is `nil' - the standard XEmacs scrolling commands essentially just call the - original versions of themselves. (Note that even when `scroll-in-place' - is `nil' the new versions of `scroll-down' and `scroll-up' have slightly - different behavior when a minibuffer window is the selected window. See - below.) - - It is possible to turn off (or turn on) \"in place\" scrolling for certain - buffers by making buffer-local bindings of the variable `scroll-in- - place' for those buffers. The variable `scroll-in-place' is not usually - buffer-local, but you can make it so if you desire. - -+ Because the improved scrolling commands keep point at its original - window position, these scrolling commands are \"reversible.\" The - `scroll-up' command undoes the effect of the immediately previous - `scroll-down' command (if any) and vice versa. In other words, if you - scroll up and then immediately scroll back down, the window config- - uration is restored to its exact original state. This allows you to - browse through a buffer more easily, as you can always get back to the - original configuration. - - Note, however, that the improved scrolling commands are guaranteed to be - reversible only if there are no intervening non-scrolling commands. - Also, if you give a prefix argument to a scrolling command (in order to - specify the number of lines to scroll by), previous scrolling commands - may no longer be reversible. More specifically, if the new prefix - argument has a different magnitude than the previous scrolling distance, - then any previous scrolling commands are not reversible. The new prefix - argument takes precedence. - - You might find it useful to think of the scrolling commands as forming - \"chains.\" A scrolling command either starts or continues a chain. By - issuing a non-scrolling command or by changing the number of lines to be - scrolled, you break the chain. (Note that simply changing the scrolling - direction won't break the chain; changing the absolute number of lines - to be scrolled is what breaks the chain.) Scrolling commands are - guaranteed to be reversible only within the current chain. Hopefully - that's clear enough. - -+ When a scrolling command is given a prefix argument (which specifies the - number of lines to scroll by), then that argument becomes the default - scrolling distance for all immediately subsequent scrolling commands. - This means that you can easily set the scrolling distance for a chain - of scrolling commands. Note that a new prefix argument or any non- - scrolling command breaks the chain (as described above), and any further - scrolling commands will use the usual defaults (or the prefix argument - you specify at that time, of course). - - However, there are cases in which one doesn't want the current scrolling - command to use the default scrolling distance that was set by the - previous scrolling command. For example, suppose that you had special - commands that scrolled one line up and one line down. When you invoke - one of these commands, the \"in place\" scrolling routines set the default - scrolling distance to be just one line. Now suppose that you use one of - your special commands and then immediately invoke `scroll-up' (`C-v'), - expecting it to scroll by a near windowful of text. You would be - disappointed --- because the previous command set the default scrolling - distance to be just one line, `scroll-up' just scrolls by one line. - - To solve this problem, \"scroll-in-place\" allows you to divide scrolling - commands into separate \"groups.\" Commands in a group can only form - chains with (and therefore, inherit defaults from) commands in the same - group. (Note that no command can be in more than one group.) If you - invoke a scrolling command that is not in the same group as that of the - immediately previous scrolling command, then the previous chain is - broken and you start a new chain --- with a new set of defaults. - - So to solve the problem described above, you could put your one-line - scrolling commands in their own group. Once that is done, the standard - scrolling commands will not form chains with your one-line scrolling - commands, and therefore will not use the default scrolling distance set - by those commands. Problem solved! - - By default, all \"in place\" scrolling commands are in a single group. If - you want to partition some commands into separate groups, you must do - that yourself *before* any \"in place\" commands are invoked. For more - information about grouping commands, see the documentation for the - variables `scroll-command-groups' and `scroll-default-command-group'. - -+ The improved scrolling commands will avoid displaying empty lines past - the end of the buffer when possible. In other words, just as you can't - see \"dead space\" before the beginning of the buffer text, the new - scrolling commands try to avoid displaying \"dead space\" past the end of - the buffer text. This behavior is somewhat configurable; see the - documentation for the variable `scroll-allow-blank-lines-past-eob'. - - Dead space will be displayed if it is necessary in order to make a - previous scrolling action reversible, however. - -+ If the scrolling commands cannot keep point at its initial window - position (because a buffer boundary is on screen and the window can't be - scrolled as far as necessary to keep point at the right place), point is - allowed to temporarily stray from its initial window position. That is, - point moves the correct number of window lines, even if it means that it - has to stray from its desired window position. This straying is undone - when (and if) the scrolling action is reversed. - -+ If a scrolling command tries to move point past a buffer boundary, point - is instead moved to the boundary (the beginning or the end of the buffer - as appropriate) and an appropriate message is displayed. This motion is - reversible, of course. - - However, if point was already at the buffer boundary when the scrolling - command was invoked, the command signals an appropriate error instead. - -+ When a minibuffer window is the selected window, the new versions of - `scroll-up' and `scroll-down' either scroll the window in the variable - `minibuffer-scroll-window' (which is usually the window of completions) - or the `next-window' if there is no `minibuffer-scroll-window'. This is - usually much more useful than scrolling the minibuffer itself. (Note - that this feature is available even when the variable `scroll-in-place' - is `nil'.) - -+ When a scrolling command is scrolling a window other than the selected - window, it will signal an appropriate buffer boundary error if the - window cannot be scrolled (because the appropriate buffer boundary is - already visible). This means that an error is signalled even in cases - that would be allowed (by \"straying\" point or by moving it to the buffer - boundary) if the window were selected. - - (If an error were not signalled in these cases, then there would be many - cases in which the last scroll in a particular direction would appear to - do nothing because only the point position would change --- the - displayed text would stay the same! To avoid these cases the scrolling - commands signal boundary errors \"prematurely\" when the window to be - scrolled is not selected.)" - :short-doc "Keep cursor on same line when scrolling" - :require 'scroll-in-place - :enable #'turn-on-scroll-in-place - :disable #'turn-off-scroll-in-place) - -(define-behavior 'mouse-avoidance -"For those who are annoyed by the mouse pointer obscuring text, -this mode moves the mouse pointer - either just a little out of -the way, or all the way to the corner of the frame. - -Customize `mouse-avoidance-mode' to one of the symbols `banish', -`exile', `jump', `animate', `cat-and-mouse', `proteus', or `none'. - -Effects of the different modes: - * banish: Move the mouse to the upper-right corner on any keypress. - * exile: Move the mouse to the corner only if the cursor gets too close, - and allow it to return once the cursor is out of the way. - * jump: If the cursor gets too close to the mouse, displace the mouse - a random distance & direction. - * animate: As `jump', but shows steps along the way for illusion of motion. - * cat-and-mouse: Same as `animate'. - * proteus: As `animate', but changes the shape of the mouse pointer too. - -Whenever the mouse is moved, the frame is also raised. - -\(see `mouse-avoidance-threshold' for definition of \"too close\", -and `mouse-avoidance-nudge-dist' and `mouse-avoidance-nudge-var' for -definition of \"random distance\".)" - :short-doc "Keep mouse away from cursor" - :enable #'(lambda () - (mouse-avoidance-mode 'animate)) - :disable #'(lambda () - (mouse-avoidance-mode 'none))) - -(define-behavior 'jka-compr - "This package implements low-level support for reading, writing, -and loading compressed files. It hooks into the low-level file -I/O functions (including write-region and insert-file-contents) so -that they automatically compress or uncompress a file if the file -appears to need it (based on the extension of the file name). -Packages like Rmail, VM, GNUS, and Info should be able to work -with compressed files without modification." - :short-doc "Transparently handle compressed files" - :enable #'jka-compr-install - :disable #'jka-compr-uninstall) - -(define-behavior 'efs -"EFS is a system for transparent file-transfer between remote VMS, CMS, -MTS, MVS, Twenex, Explorer (the last two are Lisp machines), TOPS-20, -DOS (running the Distinct, Novell, FTP software, NCSA, Microsoft in both -unix and DOS mode, Super TCP, and Hellsoft FTP servers), Windows NT -\(running the Microsoft or Hummingbird ftp servers), Unix descriptive -listings (dl), KA9Q, OS/2 hosts using FTP. This means that you can edit, -copy and otherwise manipulate files on any machine you have access to -from within Emacs as if it were a local file. EFS works by introducing -an extended filename syntax, and overloading functions such as -`insert-file-contents' so that accessing a remote file causes -appropriate commands to be sent to an FTP process. - -The syntax to use is like this: - -\(for anonymous:) /ftp.xemacs.org:/pub/xemacs/ -\(for non-anonymous:) /ben＠gwyn.tux.org:/etc/mail/xemacs/aliases-xemacs - -You can specify either a file or a directory (in the latter case, -Dired will be brought up). All operations in XEmacs on such files -should work exactly as on any other files, modulo the additional -slowness." - :short-doc "Transparent file access over FTP" - :require 'efs-auto - :enable #'ignore - ;; can't :disable - ) - - -(define-behavior 'resize-minibuffer - "When this behavior is enabled, the minibuffer is dynamically resized to -contain the entire region of text put in it as you type. - -The maximum height to which the minibuffer can grow is controlled by the -variable `resize-minibuffer-window-max-height'. - -The variable `resize-minibuffer-window-exactly' determines whether the -minibuffer window should ever be shrunk to make it no larger than needed to -display its contents. - -When using a window system, it is possible for a minibuffer to be the sole -window in a frame. Since that window is already its maximum size, the only -way to make more text visible at once is to increase the size of the frame. -The variable `resize-minibuffer-frame' controls whether this should be -done. The variables `resize-minibuffer-frame-max-height' and -`resize-minibuffer-frame-exactly' are analogous to their window -counterparts." - :short-doc "Resize minibuffer automatically" - :enable #'(lambda () - (resize-minibuffer-mode 1)) - :disable #'(lambda () - (resize-minibuffer-mode -1))) - -(define-behavior 'func-menu - "Suppose you have a file with a lot of functions in it. Well, this -package makes it easy to jump to any of those functions. The names of -the functions in the current buffer are automatically put into menubar -menu, you select one of the function-names and the point is moved to -that very function. The mark is pushed on the mark-ring, so you can -easily go back to where you were. Alternatively, you can use enter the -name of the desired function via the minibuffer which offers -completing read input. In addition, the name of the function before -point is optionally displayed in the modeline." - :short-doc "Add a menu of defined functions" - :require 'func-menu - :enable #'(lambda () - (add-hook 'find-file-hooks 'fume-add-menubar-entry) - (mapc #'(lambda (buffer) - (with-current-buffer buffer - (setq fume-display-in-modeline-p t) - (fume-add-menubar-entry))) - (buffer-list))) - :disable #'(lambda () - (remove-hook 'find-file-hooks 'fume-add-menubar-entry) - (fset 'widen (symbol-function 'fume-widen)) - (fset 'narrow-to-region (symbol-function 'narrow-to-region)) - (mapc #'(lambda (buffer) - (with-current-buffer buffer - (fume-remove-menubar-entry) - (setq fume-display-in-modeline-p nil) - (fume-remove-post-command-hook - 'fume-tickle-modeline) - (fume-remove-post-command-hook - 'fume-maybe-install-modeline-feature) - (fume-remove-post-command-hook - 'fume-rescan-buffer-trigger))) - (buffer-list)))) - -(define-behavior 'mwheel - "This code enables the use of the infamous 'wheel' on the new -crop of mice. Under XFree86 and the XSuSE X Servers, the wheel -events are sent as button4/button5 events, which are automatically -set up to do scrolling in the expected way. The actual way that the -scrolling works can be controlled by `mwheel-scroll-amount' and -`mwheel-follow-mouse'." - :short-doc "Mouse wheel support for X Windows" - :enable 'mwheel-install) - -(define-behavior 'recent-files -"Recent-files adds the menu \"Recent Files\" (or whatever name you -choose, see \"Customization:\" below) to Emacs's menubar. Its -entries are the files (and directories) that have recently been -opened by Emacs. You can open one of these files again by -selecting its entry in the \"Recent Files\" menu. The list of file -entries in this menu is preserved from one Emacs session to -another. You can prevent Emacs from saving this list by selecting -\"Don't save recent-files list on exit\" from the menu. If you have -disabled saving, you can re-enable it by selecting \"Save -recent-files list on exit\". - -The menu has permanent and non-permanent entries. Permanent -entries are marked with an asterisk in front of the filename. The -non-permanent entries are hidden in a submenu. - -Each time you open a file in Emacs, it is added as a non-permanent -entry to the menu. The value of `recent-files-number-of-entries' -determines how many non-permanent entries are held in the -menu. When the number of non-permanent entries reaches this value, -the least recently added non-permanent entry is removed from the -menu when another non-permanent entry is added. It is not removed -from the list, though; it may reappear when entries are deleted -from the list. The number of entries saved to disk is the value of -the variable `recent-files-number-of-saved-entries'. - -Permanent entries are not removed from the menu. You can make a -file entry permanent by selecting \"Make <buffer> permanent\" (where -<buffer> is the name of the current buffer) when the current -buffer holds this file. \"Make <buffer> non-permanent\" makes the -file entry of the current buffer non-permanent. - -The command \"Kill buffer <buffer> and delete entry\" is handy when -you have accidently opened a file but want to keep neither the -buffer nor the entry. - -You can erase the list of non-permanent entries by selecting -\"Erase non-permanent entries\" from the menu. - -Customization: - -There are lots of variables to control the behaviour of -recent-files. You do not have to change any of them if you like it -as it comes out of the box. However, you may want to look at these -options to make it behave different. - -`recent-files-number-of-entries' - Controls how many non-permanent entries are shown in the - recent-files list. The default is 15. - -`recent-files-number-of-saved-entries' - Controls how many non-permanent entries are saved to disk when - Emacs exits or recent-files-save-the-list is called. The - default is 50. - -`recent-files-save-file' - The name of the file where the recent-files list is saved - between Emacs session. You probably don't need to change this. - The default is \".recent-files.el\" in your home directory. - -`recent-files-dont-include' - A list of regular expressions for files that should not be - included into the recent-files list. This list is empty by - default. For instance, a list to exclude all .newsrc - files, all auto-save-files, and all files in the /tmp - directory (but not the /tmp directory itself) would look - like this: - (setq recent-files-dont-include - '(\"/\\.newsrc\" \"~$\" \"^/tmp/.\")) - The default is empty. - -`recent-files-use-full-names' - If the value of this variable is non-nil, the full pathnames of - the files are shown in the recent-files menu. Otherwise only - the filename part (or the last name component if it is a - directory) is shown in the menu. The default it t, i.e. show - full names. - -`recent-files-filename-replacements' - This is a list of pairs of regular expressions and replacement - strings. If a filename matches one of the regular expressions, - the matching part is replaced by the replacement string for - display in the recent-files menu. - Example: My home directory is \"/users/mmc/nickel/\". I want to - replace it with \"~/\". I also want to replace the directory - \"/imports/teleservices/mmc/avc2/\", where I work a lot, with - \".../avc2/\". The list then looks like - (setq recent-files-filename-replacements - '((\"/users/mmc/nickel/\" . \"~/\") - (\"/imports/teleservices/mmc/avc2/\" . \".../avc2/\"))) - Only the first match is replaced. So, if you have several - entries in this list that may match a filename simultaneously, - put the one you want to match (usually the most special) in - front of the others. The default is to replace the home - directory with \"~\". - -`recent-files-sort-function' - Contains a function symbol to sort the display of filenames in - the recent-files menu. Supplied are two functions, - 'recent-files-dont-sort and 'recent-files-sort-alphabetically. - The first, which is the default, preserves the order of \"most - recent on top\". - -`recent-files-permanent-submenu' - If this variable is non-nil, the permanent entries are put into - a separate submenu of the recent-files menu. The default is - nil. - -`recent-files-non-permanent-submenu' - If this variable is non-nil, the non-permanent entries are put - into a separate submenu of the recent-files menu. The default - is nil. (You can set both `recent-files-permanent-submenu' and - `recent-files-non-permanent-submenu' to t to have both lists in - separate submenus.) - -`recent-files-commands-submenu' - If this variable is non-nil, the commands if recent-files are - placed in a submenu of the recent-files menu. The default is - nil. - -`recent-files-commands-submenu-title' - If the commands are placed in a submenu, this string is used as - the title of the submenu. The default is \"Commands...\". - -`recent-files-actions-on-top' - If this variable is non-nil, the \"action\" menu entries (\"Make - <buffer> permanent\" etc.) are put on top of the menu. Otherwise - they appear below the file entries or submenus. The default is - nil. - -`recent-files-permanent-first' - If this variable is t, the permanent entries are put first in - the recent-files menu, i.e. above the non-permanent entries. If - the value is nil, non-permanent entries appear first. If the - value is neither t nor nil, the entries are sorted according to - recent-files-sort-function. The default is 'sort. - -`recent-files-find-file-command' - This variable contains to commandto execute when a file entry - is selected from the menu. Usually this will be `find-file', - which is the default. - -KNOWN BUG: - - recent-files overwrites the recent-files-save-file - unconditionally when Emacs exits. If you have two Emacs - processes running, the one exiting later will overwrite the - file without merging in the new entries from the other Emacs - process. This can be avoided by disabling the save on exit from - the menu." - :short-doc "`Recent Files' menu" - :enable 'recent-files-initialize) - -(define-behavior 'filladapt - "These functions enhance the default behavior of Emacs' Auto Fill -mode and the commands `fill-paragraph', `lisp-fill-paragraph', -`fill-region-as-paragraph' and `fill-region'. - -The chief improvement is that the beginning of a line to be -filled is examined and, based on information gathered, an -appropriate value for fill-prefix is constructed. Also the -boundaries of the current paragraph are located. This occurs -only if the fill prefix is not already non-nil. - -The net result of this is that blurbs of text that are offset -from left margin by asterisks, dashes, and/or spaces, numbered -examples, included text from USENET news articles, etc. are -generally filled correctly with no fuss." - :short-doc "Adaptive (smart) filling" - :require 'filladapt - :enable #'(lambda () - (setq-default filladapt-mode t) - (mapc #'(lambda (buffer) - (with-current-buffer buffer - (unless filladapt-mode - (filladapt-mode 1)))) - (buffer-list))) - :disable #'(lambda () - (setq-default filladapt-mode nil) - (mapc #'(lambda (buffer) - (with-current-buffer buffer - (when filladapt-mode - (filladapt-mode -1)))) - (buffer-list)))) +(define-behavior-group 'tty) +(define-behavior-group 'toolbars) +(define-behavior-group 'menus) +(define-behavior-group 'mouse) +(define-behavior-group 'editing) +(define-behavior-group 'keyboard) +(define-behavior-group 'files) +(define-behavior-group 'games) +(define-behavior-group 'processes) +(define-behavior-group 'display) +(define-behavior-group 'programming) +(define-behavior-group 'international) +(define-behavior-group 'buffers-and-windows) +(define-behavior-group 'internet) + +(define-behavior 'compose-mail + "Not documented." + :group 'internet + :commands + '(["Send %_Mail..." compose-mail])) 1.7 +12 -0 XEmacs/xemacs/lisp/mwheel.el (In the diff below, changes in quantity of whitespace are not shown.) Index: mwheel.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mwheel.el,v retrieving revision 1.6 retrieving revision 1.7 diff -u -b -r1.6 -r1.7 --- mwheel.el 2003/08/13 11:22:43 1.6 +++ mwheel.el 2005/02/03 05:26:41 1.7 ＠＠ -126,6 +126,18 ＠＠ (setq keys (cdr keys))) (error nil)))) +;;;###autoload +(define-behavior 'mwheel + "This code enables the use of the infamous 'wheel' on the new +crop of mice. Under XFree86 and the XSuSE X Servers, the wheel +events are sent as button4/button5 events, which are automatically +set up to do scrolling in the expected way. The actual way that the +scrolling works can be controlled by `mwheel-scroll-amount' and +`mwheel-follow-mouse'." + :group 'mouse + :short-doc "Mouse wheel support for X Windows" + :enable 'mwheel-install) + (provide 'mwheel) ;;; mwheel.el ends here

1 participants
0 comments

CVS update: MODIFIED: src ... 20 years, 2 months

CVS Monitor

User: ben Date: 05/02/03 06:03:47 Modified: xemacs/src ChangeLog menubar.c Log: behavior ws #2: menu-related changes menubar.c: New fun to compare menu itext as if the two were normalized. menubar.c: Rename; there are no external callers of this function. Remove unneeded BUFFER argument. Don't downcase. (This will be done in compare-menu-text.) Document that return value may be same string. easymenu.el, map-ynp.el: Use normalize-menu-text not normalize-menu-item-name. menubar-items.el, menubar.el: Move to menubar.el and rewrite for cleanliness. menubar-items.el: Use menu-split-long-menu-and-sort. menubar-items.el, menubar.el: Move to menubar.el. menubar.el: New funs. menubar.el: Split up find-menu-item w/find-menu-item-1, since PARENT is not an external item. Rewrite to use compare-menu-text. menubar.el: Don't normalize items as find-menu-item does not need it. menubar-items.el: Delete old Behavior menu defn, replaced by behavior-menu-filter. Planning to [[Delete many menus from Tools menu -- they have been integrated as part of the behavior system.]] Currently the new Tools menu (very short, just a call to the behavior-menu-filter) is commented out, and the old Toold menu defn remains. Once the new packages are in place (c. 1 or 2 weeks), I'll make the switchover. Use menu-split-long-menu-and-sort. Revision Changes Path 1.622 +54 -49 XEmacs/xemacs/lisp/ChangeLog (In the diff below, changes in quantity of whitespace are not shown.) Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/ChangeLog,v retrieving revision 1.621 retrieving revision 1.622 diff -u -b -r1.621 -r1.622 --- ChangeLog 2005/02/03 04:29:32 1.621 +++ ChangeLog 2005/02/03 05:03:36 1.622 ＠＠ -1,5 +1,59 ＠＠ 2005-02-02 Ben Wing <ben(a)xemacs.org> + * easymenu.el (easy-menu-add): + * easymenu.el (easy-menu-remove): + * map-ynp.el (map-y-or-n-p): + Use normalize-menu-text not normalize-menu-item-name. + + * menubar-items.el (submenu-generate-accelerator-spec): Removed. + * menubar.el (submenu-generate-accelerator-spec): New. + Move to menubar.el and rewrite for cleanliness. + + * menubar-items.el (coding-system-menu-filter): + Use menu-split-long-menu-and-sort. + + * menubar-items.el (menu-item-strip-accelerator-spec): Removed. + * menubar-items.el (menu-item-generate-accelerator-spec): Removed. + * menubar-items.el (menu-max-items): Removed. + * menubar-items.el (menu-submenu-max-items): Removed. + * menubar-items.el (menu-submenu-name-format): Removed. + * menubar-items.el (menu-split-long-menu): Removed. + * menubar-items.el (menu-sort-menu): Removed. + * menubar.el (menu-item-strip-accelerator-spec): New. + * menubar.el (menu-item-generate-accelerator-spec): New. + * menubar.el (menu-max-items): New. + * menubar.el (menu-submenu-max-items): New. + * menubar.el (menu-submenu-name-format): New. + * menubar.el (menu-split-long-menu): New. + * menubar.el (menu-sort-menu): New. + Move to menubar.el. + + * menubar.el (menu-item-text): New. + * menubar.el (menu-split-long-menu-and-sort): New. + New funs. + + * menubar.el (find-menu-item): + * menubar.el (find-menu-item-1): New. + Split up find-menu-item w/find-menu-item-1, since PARENT is not + an external item. + Rewrite to use compare-menu-text. + + * menubar.el (add-menu-item-1): + Don't normalize items as find-menu-item does not need it. + + * menubar-items.el (default-menubar): + Delete old Behavior menu defn, replaced by behavior-menu-filter. + Planning to [[Delete many menus from Tools menu -- they have been + integrated as part of the behavior system.]] Currently the new + Tools menu (very short, just a call to the behavior-menu-filter) + is commented out, and the old Toold menu defn remains. Once the + new packages are in place (c. 1 or 2 weeks), I'll make the + switchover. + + Use menu-split-long-menu-and-sort. + +2005-02-02 Ben Wing <ben(a)xemacs.org> + * cus-dep.el (Custom-make-dependencies-1): If a directory has no custom dependencies, write a blank custom-load file rather than deleting the file, so that ＠＠ -182,55 +236,6 ＠＠ * behavior.el (behavior-menu-filter-1): New. * behavior.el (behavior-menu-filter): New. Major update. Add documentation of how it works. - - * easymenu.el (easy-menu-add): - * easymenu.el (easy-menu-remove): - * map-ynp.el (map-y-or-n-p): - Use normalize-menu-text not normalize-menu-item-name. - - * menubar-items.el (submenu-generate-accelerator-spec): Removed. - * menubar.el (submenu-generate-accelerator-spec): New. - Move to menubar.el and rewrite for cleanliness. - - * menubar-items.el (coding-system-menu-filter): - Use menu-split-long-menu-and-sort. - - * menubar-items.el (menu-item-strip-accelerator-spec): Removed. - * menubar-items.el (menu-item-generate-accelerator-spec): Removed. - * menubar-items.el (menu-max-items): Removed. - * menubar-items.el (menu-submenu-max-items): Removed. - * menubar-items.el (menu-submenu-name-format): Removed. - * menubar-items.el (menu-split-long-menu): Removed. - * menubar-items.el (menu-sort-menu): Removed. - * menubar.el (menu-item-strip-accelerator-spec): New. - * menubar.el (menu-item-generate-accelerator-spec): New. - * menubar.el (menu-max-items): New. - * menubar.el (menu-submenu-max-items): New. - * menubar.el (menu-submenu-name-format): New. - * menubar.el (menu-split-long-menu): New. - * menubar.el (menu-sort-menu): New. - Move to menubar.el. - - * menubar.el (menu-item-text): New. - * menubar.el (menu-split-long-menu-and-sort): New. - New funs. - - * menubar-items.el (default-menubar): - Delete many menus from Tools menu -- they have been integrated - as part of the behavior system. - - Delete old Behavior menu defn. Use behavior-menu-filter. - - Use menu-split-long-menu-and-sort. - - * menubar.el (find-menu-item): - * menubar.el (find-menu-item-1): New. - Split up find-menu-item w/find-menu-item-1, since PARENT is not - an external item. - Rewrite to use compare-menu-text. - - * menubar.el (add-menu-item-1): - Don't normalize items as find-menu-item does not need it. * mwheel.el: * mwheel.el ('mwheel): New. 1.11 +164 -15 XEmacs/xemacs/lisp/menubar.el (In the diff below, changes in quantity of whitespace are not shown.) Index: menubar.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/menubar.el,v retrieving revision 1.10 retrieving revision 1.11 diff -u -b -r1.10 -r1.11 --- menubar.el 2001/12/20 05:49:31 1.10 +++ menubar.el 2005/02/03 05:03:37 1.11 ＠＠ -2,7 +2,7 ＠＠ ;; Copyright (C) 1991-4, 1997-1998 Free Software Foundation, Inc. ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. -;; Copyright (C) 1995, 1996 Ben Wing. +;; Copyright (C) 1995, 1996, 2003 Ben Wing. ;; Maintainer: XEmacs Development Team ;; Keywords: internal, extensions, dumped ＠＠ -163,17 +163,27 ＠＠ (setq menu (cdr menu))))) -;;; menu manipulation functions +;;; basic menu manipulation functions -(defun find-menu-item (menubar item-path-list &optional parent) - "Search MENUBAR for item given by ITEM-PATH-LIST starting from PARENT. +(defun menu-item-text (item &optional normalize) + "Return the text that is displayed for a menu item. +If ITEM is a string (unselectable text), it is returned; otherwise, +the first element of the cons or vector is returned. +If NORMALIZE is non-nil, pass the text through `normalize-menu-text' +before being returned, to remove accelerator specs and convert %% to %." + (let ((val (if (stringp item) item (elt item 0)))) + (if normalize (normalize-menu-text val) val))) + +(defun find-menu-item (menubar item-path-list) + "Search MENUBAR for item given by ITEM-PATH-LIST. Returns (ITEM . PARENT), where PARENT is the immediate parent of the item found. If the item does not exist, the car of the returned value is nil. If some menu in the ITEM-PATH-LIST does not exist, an error is signalled." + (find-menu-item-1 menubar item-path-list)) + +(defun find-menu-item-1 (menubar item-path-list &optional parent) (check-argument-type 'listp item-path-list) - (unless parent - (setq item-path-list (mapcar 'normalize-menu-item-name item-path-list))) (if (not (consp menubar)) nil (let ((rest menubar) ＠＠ -184,14 +194,9 ＠＠ (setq rest (cddr rest))) (while rest (if (and (car rest) - (equal (car item-path-list) - (normalize-menu-item-name - (cond ((vectorp (car rest)) - (aref (car rest) 0)) - ((stringp (car rest)) - (car rest)) - (t - (caar rest)))))) + (stringp (car item-path-list)) + (= 0 (compare-menu-text (car item-path-list) + (menu-item-text (car rest))))) (setq result (car rest) rest nil) (setq rest (cdr rest)))) ＠＠ -208,7 +213,6 ＠＠ (defun add-menu-item-1 (leaf-p menu-path new-item before in-menu) ;; This code looks like it could be cleaned up some more ;; Do we really need 6 calls to find-menu-item? - (when before (setq before (normalize-menu-item-name before))) (let* ((item-name (cond ((vectorp new-item) (aref new-item 0)) ((consp new-item) (car new-item)) ＠＠ -463,6 +467,151 ＠＠ menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." (enable-menu-item-1 path t nil)) + +;;; functions for manipulating whole menus -- adding accelerators, sorting, +;;; splitting long menus, etc. + +(defun submenu-generate-accelerator-spec (list &optional omit-chars-list) + "Add auto-generated accelerator specifications to a submenu. +This can be used to add accelerators to the return value of a menu filter +function. It correctly ignores unselectable items. It will destructively +modify the list passed to it. If an item already has an auto-generated +accelerator spec, this will be removed before the new one is added, making +this function idempotent. + +If OMIT-CHARS-LIST is given, it should be a list of lowercase characters, +which will not be used as accelerators." + (let ((n 0)) + (dolist (item list list) + (cond + ((or (vectorp item) (consp item)) + (incf n) + (setf (elt item 0) + (concat + (menu-item-generate-accelerator-spec n omit-chars-list) + (menu-item-strip-accelerator-spec (elt item 0))))))))) + +(defun menu-item-strip-accelerator-spec (item) + "Strip an auto-generated accelerator spec off of ITEM. +ITEM should be a string. This removes specs added by +`menu-item-generate-accelerator-spec' and `submenu-generate-accelerator-spec'." + (if (string-match "%_. " item) + (substring item 4) + item)) + +(defun menu-item-generate-accelerator-spec (n &optional omit-chars-list) + "Return an accelerator specification for use with auto-generated menus. +This should be concat'd onto the beginning of each menu line. The spec +allows the Nth line to be selected by the number N. '0' is used for the +10th line, and 'a' through 'z' are used for the following 26 lines. + +If OMIT-CHARS-LIST is given, it should be a list of lowercase characters, +which will not be used as accelerators." + (cond ((< n 10) (concat "%_" (int-to-string n) " ")) + ((= n 10) "%_0 ") + ((<= n 36) + (setq n (- n 10)) + (let ((m 0)) + (while (> n 0) + (setq m (1+ m)) + (while (memq (int-to-char (+ m (- (char-to-int ?a) 1))) + omit-chars-list) + (setq m (1+ m))) + (setq n (1- n))) + (if (<= m 26) + (concat + "%_" + (char-to-string (int-to-char (+ m (- (char-to-int ?a) 1)))) + " ") + ""))) + (t ""))) + +(defcustom menu-max-items 25 + "*Maximum number of items in generated menus. +If number of entries in such a menu is larger than this value, split menu +into submenus of nearly equal length (see `menu-submenu-max-items'). If +nil, never split menu into submenus." + :group 'menu + :type '(choice (const :tag "no submenus" nil) + (integer))) + +(defcustom menu-submenu-max-items 20 + "*Maximum number of items in submenus when splitting menus. +We split large menus into submenus of this many items, and then balance +them out as much as possible (otherwise the last submenu may have very few +items)." + :group 'menu + :type 'integer) + +(defcustom menu-submenu-name-format "%-12.12s ... %.12s" + "*Format specification of the submenu name when splitting menus. +Used by `menu-split-long-menu' if the number of entries in a menu is +larger than `menu-menu-max-items'. +This string should contain one %s for the name of the first entry and +one %s for the name of the last entry in the submenu. +If the value is a function, it should return the submenu name. The +function is be called with two arguments, the names of the first and +the last entry in the menu." + :group 'menu + :type '(choice (string :tag "Format string") + (function))) + +(defun menu-split-long-menu-and-sort (menu) + "Sort MENU, split according to `menu-max-items' and add accelerator specs. +This is useful for menus generated by filter functions, to make them look +nice. This is equivalent to + +\(menu-split-long-menu (menu-sort-menu menu)) + +and you can call those functions individually if necessary. +You can also call `submenu-generate-accelerator-spec' yourself to add +accelerator specs -- this works even if the specs have already been added." + (menu-split-long-menu (menu-sort-menu menu))) + +(defun menu-split-long-menu (menu) + "Split MENU according to `menu-max-items' and add accelerator specs. +If MENU already has accelerator specs, they will be removed and new ones +generated. You should normally use `menu-split-long-menu-and-sort' instead. +The menu should already be sorted to get meaningful results when it is +split, since the outer menus are of the format `FROM ... TO'." + (let ((len (length menu))) + (if (or (null menu-max-items) + (<= len menu-max-items)) + (submenu-generate-accelerator-spec menu) + (let* ((outer (/ (+ len (1- menu-submenu-max-items)) + menu-submenu-max-items)) + (inner (/ (+ len (1- outer)) outer)) + (result nil)) + (while menu + (let ((sub nil) + (from (car menu))) + (dotimes (foo (min inner len)) + (setq sub (cons (car menu) sub) + menu (cdr menu))) + (setq len (- len inner)) + (let* ((to (car sub)) + (ftext (menu-item-strip-accelerator-spec + (menu-item-text from))) + (ttext (menu-item-strip-accelerator-spec + (menu-item-text to)))) + (setq sub (nreverse sub)) + (setq result + (cons (cons (if (stringp menu-submenu-name-format) + (format menu-submenu-name-format + ftext ttext) + (funcall menu-submenu-name-format + ftext ttext)) + (submenu-generate-accelerator-spec sub)) + result))))) + (submenu-generate-accelerator-spec (nreverse result)))))) + +(defun menu-sort-menu (menu) + "Sort MENU alphabetically. +You should normally use `menu-split-long-menu-and-sort' instead." + (sort menu + #'(lambda (a b) (< (compare-menu-text + (menu-item-text a) (menu-item-text b)) + 0)))) ;;;;;;; popup menus 1.46 +53 -203 XEmacs/xemacs/lisp/menubar-items.el (In the diff below, changes in quantity of whitespace are not shown.) Index: menubar-items.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/menubar-items.el,v retrieving revision 1.45 retrieving revision 1.46 diff -u -b -r1.45 -r1.46 --- menubar-items.el 2005/01/26 04:56:18 1.45 +++ menubar-items.el 2005/02/03 05:03:38 1.46 ＠＠ -67,149 +67,7 ＠＠ list (butlast list (- (length list) count))))) -(defun submenu-generate-accelerator-spec (list &optional omit-chars-list) - "Add auto-generated accelerator specifications to a submenu. -This can be used to add accelerators to the return value of a menu filter -function. It correctly ignores unselectable items. It will destructively -modify the list passed to it. If an item already has an auto-generated -accelerator spec, this will be removed before the new one is added, making -this function idempotent. -If OMIT-CHARS-LIST is given, it should be a list of lowercase characters, -which will not be used as accelerators." - (let ((n 0)) - (dolist (item list list) - (cond - ((vectorp item) - (setq n (1+ n)) - (aset item 0 - (concat - (menu-item-generate-accelerator-spec n omit-chars-list) - (menu-item-strip-accelerator-spec (aref item 0))))) - ((consp item) - (setq n (1+ n)) - (setcar item - (concat - (menu-item-generate-accelerator-spec n omit-chars-list) - (menu-item-strip-accelerator-spec (car item))))))))) - -(defun menu-item-strip-accelerator-spec (item) - "Strip an auto-generated accelerator spec off of ITEM. -ITEM should be a string. This removes specs added by -`menu-item-generate-accelerator-spec' and `submenu-generate-accelerator-spec'." - (if (string-match "%_. " item) - (substring item 4) - item)) - -(defun menu-item-generate-accelerator-spec (n &optional omit-chars-list) - "Return an accelerator specification for use with auto-generated menus. -This should be concat'd onto the beginning of each menu line. The spec -allows the Nth line to be selected by the number N. '0' is used for the -10th line, and 'a' through 'z' are used for the following 26 lines. - -If OMIT-CHARS-LIST is given, it should be a list of lowercase characters, -which will not be used as accelerators." - (cond ((< n 10) (concat "%_" (int-to-string n) " ")) - ((= n 10) "%_0 ") - ((<= n 36) - (setq n (- n 10)) - (let ((m 0)) - (while (> n 0) - (setq m (1+ m)) - (while (memq (int-to-char (+ m (- (char-to-int ?a) 1))) - omit-chars-list) - (setq m (1+ m))) - (setq n (1- n))) - (if (<= m 26) - (concat - "%_" - (char-to-string (int-to-char (+ m (- (char-to-int ?a) 1)))) - " ") - ""))) - (t ""))) - -(defcustom menu-max-items 25 - "*Maximum number of items in generated menus. -If number of entries in such a menu is larger than this value, split menu -into submenus of nearly equal length (see `menu-submenu-max-items'). If -nil, never split menu into submenus." - :group 'menu - :type '(choice (const :tag "no submenus" nil) - (integer))) - -(defcustom menu-submenu-max-items 20 - "*Maximum number of items in submenus when splitting menus. -We split large menus into submenus of this many items, and then balance -them out as much as possible (otherwise the last submenu may have very few -items)." - :group 'menu - :type 'integer) - -(defcustom menu-submenu-name-format "%-12.12s ... %.12s" - "*Format specification of the submenu name when splitting menus. -Used by `menu-split-long-menu' if the number of entries in a menu is -larger than `menu-menu-max-items'. -This string should contain one %s for the name of the first entry and -one %s for the name of the last entry in the submenu. -If the value is a function, it should return the submenu name. The -function is be called with two arguments, the names of the first and -the last entry in the menu." - :group 'menu - :type '(choice (string :tag "Format string") - (function))) - -(defun menu-split-long-menu (menu) - "Split MENU according to `menu-max-items' and add accelerator specs. - -You should normally use the idiom - -\(menu-split-long-menu (menu-sort-menu menu)) - -See also `menu-sort-menu'." - (let ((len (length menu))) - (if (or (null menu-max-items) - (<= len menu-max-items)) - (submenu-generate-accelerator-spec menu) - (let* ((outer (/ (+ len (1- menu-submenu-max-items)) - menu-submenu-max-items)) - (inner (/ (+ len (1- outer)) outer)) - (result nil)) - (while menu - (let ((sub nil) - (from (car menu))) - (dotimes (foo (min inner len)) - (setq sub (cons (car menu) sub) - menu (cdr menu))) - (setq len (- len inner)) - (let ((to (car sub))) - (setq sub (nreverse sub)) - (setq result - (cons (cons (if (stringp menu-submenu-name-format) - (format menu-submenu-name-format - (menu-item-strip-accelerator-spec - (aref from 0)) - (menu-item-strip-accelerator-spec - (aref to 0))) - (funcall menu-submenu-name-format - (menu-item-strip-accelerator-spec - (aref from 0)) - (menu-item-strip-accelerator-spec - (aref to 0)))) - (submenu-generate-accelerator-spec sub)) - result))))) - (submenu-generate-accelerator-spec (nreverse result)))))) - -(defun menu-sort-menu (menu) - "Sort MENU alphabetically. - -You should normally use the idiom - -\(menu-split-long-menu (menu-sort-menu menu)) - -See also `menu-split-long-menu'." - (sort menu - #'(lambda (a b) (string-lessp (aref a 0) (aref b 0))))) - (defun coding-system-menu-filter (fun active &optional dots) "Filter for menu entries with a submenu listing all coding systems. This is for operations that take a coding system as an argument. FUN ＠＠ -225,8 +83,7 ＠＠ (lambda (entry) ...) (lambda (entry) ...)) " - (menu-split-long-menu - (menu-sort-menu + (menu-split-long-menu-and-sort (mapcar #'(lambda (_csmf_entry) `[ ,(concat (coding-system-description _csmf_entry) ＠＠ -239,7 +96,7 ＠＠ (or (coding-system-alias-p name) (not (eq name (coding-system-name (coding-system-base name)))))) - (coding-system-list)))))) + (coding-system-list))))) (defconst default-menubar ; (purecopy-menubar ;purespace is dead ＠＠ -422,7 +279,6 ＠＠ ) ) - ("C%_mds" ["Repeat Last Comple%_x Command..." repeat-complex-command] ["E%_valuate Lisp Expression..." eval-expression] ＠＠ -555,16 +411,26 ＠＠ ["Edit Ta%_b Stops" edit-tab-stops] ) "---" - ("Spell-Chec%_k" - ["%_Buffer" ispell-buffer - :active (fboundp 'ispell-buffer)] - "---" - ["%_Word" ispell-word] - ["%_Complete Word" ispell-complete-word] - ["%_Region" ispell-region] + ("%_Tags" + ["%_Find Tag..." find-tag] + ["Find %_Other Window..." find-tag-other-window] + ["%_Next Tag..." (find-tag nil)] + ["N%_ext Other Window..." (find-tag-other-window nil)] + ["Next %_File" next-file] + "-----" + ["Tags %_Search..." tags-search] + ["Tags %_Replace..." tags-query-replace] + ["%_Continue Search/Replace" tags-loop-continue] + "-----" + ["%_Pop stack" pop-tag-mark] + ["%_Apropos..." tags-apropos] + "-----" + ["%_Set Tags Table File..." visit-tags-table] ) ) + ;; #### Delete this entire menu as soon as the new package source is + ;; committed. ("%_Tools" ("%_Packages" ("%_Set Download Site" ＠＠ -816,24 +682,10 ＠＠ "----" ) - ("%_Options" - ("%_Behaviors" - :filter - (lambda (menu) - (menu-split-long-menu - (menu-sort-menu - (loop for behavior being the hash-keys in behavior-hash-table - using (hash-value plist) - collect (vector (format "%s (%s)" behavior - (getf plist :short-doc)) - `(if (memq ',behavior enabled-behavior-list) - (disable-behavior ',behavior) - (enable-behavior ',behavior)) - :style 'toggle - :selected `(memq ',behavior - enabled-behavior-list)) - ))))) +; ("%_Tools" +; :filter behavior-menu-filter) + ("%_Options" ("%_Advanced (Customize)" ("%_Emacs" :filter (lambda (&rest junk) (cdr (custom-menu-create 'emacs)))) ＠＠ -1142,8 +994,7 ＠＠ ("Set %_Language Environment" :filter (lambda (menu) - (menu-split-long-menu - (menu-sort-menu + (menu-split-long-menu-and-sort (mapcar #'(lambda (entry) `[ ,(car entry) (set-language-environment ',(car entry)) ＠＠ -1152,7 +1003,7 ＠＠ ,(equal (car entry) current-language-environment)]) language-info-alist) - )))) + ))) ["%_Toggle Input Method" toggle-input-method] ["Select %_Input Method" set-input-method] ))) ＠＠ -1681,8 +1532,7 ＠＠ ("Describe %_Language Support" :filter (lambda (menu) - (menu-split-long-menu - (menu-sort-menu + (menu-split-long-menu-and-sort (mapcar #'(lambda (entry) `[ ,(car entry) (describe-language-environment ＠＠ -1692,7 +1542,7 ＠＠ ,(equal (car entry) current-language-environment)]) language-info-alist) - )))) + ))) ["Describe %_Input Method" describe-input-method] ["Describe Current %_Coding Systems" describe-current-coding-system] 1.7 +2 -2 XEmacs/xemacs/lisp/easymenu.el (In the diff below, changes in quantity of whitespace are not shown.) Index: easymenu.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/easymenu.el,v retrieving revision 1.6 retrieving revision 1.7 diff -u -b -r1.6 -r1.7 --- easymenu.el 2001/05/04 22:42:01 1.6 +++ easymenu.el 2005/02/03 05:03:38 1.7 ＠＠ -181,7 +181,7 ＠＠ (reverse easy-menu-all-popups)) (let ((same-as-menu (car easy-menu-all-popups))) - (cons (normalize-menu-item-name + (cons (normalize-menu-text (car same-as-menu)) (cdr same-as-menu))))) ＠＠ -208,7 +208,7 ＠＠ (reverse easy-menu-all-popups)) (let ((same-as-menu (car easy-menu-all-popups))) - (cons (normalize-menu-item-name + (cons (normalize-menu-text (car same-as-menu)) (cdr same-as-menu))))) 1.4 +3 -2 XEmacs/xemacs/lisp/map-ynp.el (In the diff below, changes in quantity of whitespace are not shown.) Index: map-ynp.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/map-ynp.el,v retrieving revision 1.3 retrieving revision 1.4 diff -u -b -r1.3 -r1.4 --- map-ynp.el 2001/04/12 18:21:30 1.3 +++ map-ynp.el 2005/02/03 05:03:38 1.4 ＠＠ -231,8 +231,9 ＠＠ (lambda (elt) (format "%c to %s" (nth 0 elt) - (normalize-menu-item-name - (nth 2 elt))))) + (downcase + (normalize-menu-text + (nth 2 elt)))))) action-alist ";\n") (if action-alist ";\n") 1.783 +53 -0 XEmacs/xemacs/src/ChangeLog (In the diff below, changes in quantity of whitespace are not shown.) Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/ChangeLog,v retrieving revision 1.782 retrieving revision 1.783 diff -u -b -r1.782 -r1.783 --- ChangeLog 2005/01/31 19:29:47 1.782 +++ ChangeLog 2005/02/03 05:03:43 1.783 ＠＠ -1,3 +1,56 ＠＠ +2005-02-02 Ben Wing <ben(a)xemacs.org> + + * menubar.c: + * menubar.c (Fcompare_menu_text): + New fun to compare menu itext as if the two were normalized. + + * menubar.c (Fnormalize_menu_text): + * menubar.c (syms_of_menubar): + Rename; there are no external callers of this function. + Remove unneeded BUFFER argument. Don't downcase. + (This will be done in compare-menu-text.) + Document that return value may be same string. + +2005-02-02 Ben Wing <ben(a)xemacs.org> + + * lread.c: + * lread.c (check_if_suppressed): + * lread.c (Fload_internal): + * lread.c (locate_file_in_directory_mapper): + * lread.c (readevalloop): + * lread.c (syms_of_lread): + * lread.c (vars_of_lread): + * menubar.c: + * menubar.c (Fcompare_menu_text): + * menubar.c (Fnormalize_menu_text): + * menubar.c (syms_of_menubar): + * menubar.c (vars_of_menubar): + +2004-11-09 Ben Wing <ben(a)xemacs.org> + + * lisp.h: + + * lread.c: + * lread.c (check_if_suppressed): + * lread.c (Fload_internal): + * lread.c (locate_file_in_directory_mapper): + * lread.c (readevalloop): + * lread.c (syms_of_lread): + * lread.c (vars_of_lread): + Remove undeeded Vload_file_name_internal_the_purecopy, + Qload_file_name -- use internal_bind_lisp_object instead of + specbind. + + Add load-suppress-alist. + +2003-02-15 Ben Wing <ben(a)xemacs.org> + + * syswindows.h: Define W32API_2_2 for w32api.h v2.2 or higher. + Use it when defining a missing structure that is present in this + version of w32api.h. + * event-msw.c (mswindows_wnd_proc): Conditionalize bug fix on + !W32API_2_2. + 2005-01-31 Ben Wing <ben(a)xemacs.org> * emacs.c: 1.29 +43 -6 XEmacs/xemacs/src/menubar.c (In the diff below, changes in quantity of whitespace are not shown.) Index: menubar.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/menubar.c,v retrieving revision 1.28 retrieving revision 1.29 diff -u -b -r1.28 -r1.29 --- menubar.c 2004/11/04 23:06:41 1.28 +++ menubar.c 2005/02/03 05:03:45 1.29 ＠＠ -1,7 +1,7 ＠＠ /* Implements an elisp-programmable menubar. Copyright (C) 1993, 1994 Free Software Foundation, Inc. Copyright (C) 1995 Tinker Systems and INS Engineering Corp. - Copyright (C) 2001, 2002 Ben Wing. + Copyright (C) 2001, 2002, 2003 Ben Wing. This file is part of XEmacs. ＠＠ -326,14 +326,51 ＠＠ return Qnil; } -DEFUN ("normalize-menu-item-name", Fnormalize_menu_item_name, 1, 2, 0, /* +DEFUN ("compare-menu-text", Fcompare_menu_text, 2, 2, 0, /* +Compare the text of two menu items, ignoring accelerator specs and case. +Also treat %% as a single %. Return < 0 if STRING1 is less than STRING2, +0 if equal, > 0 if STRING1 is greater than STRING2. +*/ + (string1, string2)) +{ + Ibyte *p; + Ibyte *q; + + CHECK_STRING (string1); + CHECK_STRING (string2); + + p = XSTRING_DATA (string1); + q = XSTRING_DATA (string2); + + for (;;) + { + Ichar val; + if (*p == '%' && *(p + 1) == '%') + p++; + else if (*p == '%' && *(p + 1) == '_') + p += 2; + if (*q == '%' && *(q + 1) == '%') + q++; + else if (*q == '%' && *(q + 1) == '_') + q += 2; + if (!*p || !*q) + return make_int (*p - *q); + val = DOWNCASE (0, itext_ichar (p)) - DOWNCASE (0, itext_ichar (q)); + if (val) + return make_int (val); + INC_IBYTEPTR (p); + INC_IBYTEPTR (q); + } +} + +DEFUN ("normalize-menu-text", Fnormalize_menu_text, 1, 1, 0, /* Convert a menu item name string into normal form, and return the new string. Menu item names should be converted to normal form before being compared. This removes %_'s (accelerator indications) and converts %% to %. +The returned string may be the same string as the original. */ - (name, buffer)) + (name)) { - struct buffer *buf = decode_buffer (buffer, 0); Charcount end; int i; Ibyte *name_data; ＠＠ -352,7 +389,6 ＠＠ for (i = 0; i < end; i++) { elt = itext_ichar (name_data); - elt = DOWNCASE (buf, elt); if (expecting_underscore) { expecting_underscore = 0; ＠＠ -400,7 +436,8 ＠＠ DEFSYMBOL (Qmenu_escape); DEFSUBR (Fpopup_menu); - DEFSUBR (Fnormalize_menu_item_name); + DEFSUBR (Fcompare_menu_text); + DEFSUBR (Fnormalize_menu_text); DEFSUBR (Fmenu_find_real_submenu); }

1 participants
0 comments

CVS update: MODIFIED: lisp ... 20 years, 2 months

CVS Monitor

User: ben Date: 05/02/03 05:29:35 Modified: xemacs/lisp ChangeLog cus-dep.el cus-edit.el custom.el Log: behavior ws #1: custom updates cus-dep.el: If a directory has no custom dependencies, write a blank custom-load file rather than deleting the file, so that time-based rebuild checking will work. cus-edit.el: Split out code in custom-load-symbol. Support loading of the new custom-defines file. cus-edit.el: Split long menus. custom.el: Sync with FSF 21.3. Revision Changes Path 1.621 +261 -0 XEmacs/xemacs/lisp/ChangeLog (In the diff below, changes in quantity of whitespace are not shown.) Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/ChangeLog,v retrieving revision 1.620 retrieving revision 1.621 diff -u -b -r1.620 -r1.621 --- ChangeLog 2005/01/31 20:08:44 1.620 +++ ChangeLog 2005/02/03 04:29:32 1.621 ＠＠ -1,3 +1,264 ＠＠ +2005-02-02 Ben Wing <ben(a)xemacs.org> + + * cus-dep.el (Custom-make-dependencies-1): + If a directory has no custom dependencies, write a blank + custom-load file rather than deleting the file, so that + time-based rebuild checking will work. + + * cus-edit.el: + * cus-edit.el (custom-load-symbol): + * cus-edit.el (custom-load-symbol-1): New. + * cus-edit.el (custom-already-loaded-custom-defines): New. + * cus-edit.el (custom-define-current-source-file): New. + * cus-edit.el (custom-warn-when-reloading-necessary): New. + * cus-edit.el (custom-load-custom-defines): New. + * cus-edit.el (custom-load-custom-defines-1): New. + Split out code in custom-load-symbol. Support loading of + the new custom-defines file. + + * cus-edit.el (custom-menu-create): + Split long menus. + + * custom.el: + * custom.el (load): + * custom.el (custom-dont-initialize): New. + * custom.el (custom-current-group-alist): New. + * custom.el (custom-declare-variable): + * custom.el (defcustom): + * custom.el (custom-current-group): New. + * custom.el (custom-declare-group): + * custom.el (defgroup): + * custom.el (custom-add-to-group): + * custom.el (custom-group-of-mode): New. + * custom.el (custom-handle-all-keywords): + * custom.el (custom-autoload): New. + * custom.el (custom-variable-p): New. + * custom.el (custom-load-recursion): New. + * custom.el (custom-load-symbol): New. + * custom.el (custom-known-themes): + * custom.el (custom-declare-theme): New. + * custom.el (deftheme): + * custom.el (custom-make-theme-feature): + * custom.el (custom-check-theme): + * custom.el (custom-push-theme): + * custom.el (custom-set-variables): + * custom.el (custom-theme-set-variables): + * custom.el (custom-set-default): New. + * custom.el (custom-quote): New. + * custom.el (customize-mark-to-save): New. + * custom.el (provide-theme): + * custom.el (require-theme): + * custom.el (customize-mark-as-set): New. + * custom.el (custom-remove-theme): New. + * custom.el (custom-do-theme-reset): + * custom.el (custom-theme-load-themes): + * custom.el (custom-load-themes): + * custom.el (custom-theme-value): + * custom.el (custom-theme-variable-value): + * custom.el (custom-theme-reset-internal): + * custom.el (copy-upto-last): Removed. + * custom.el (custom-theme-reset-variables): + * custom.el (custom-reset-variables): + * custom.el: + * custom.el (load): + * custom.el (custom-dont-initialize): New. + * custom.el (custom-current-group-alist): New. + * custom.el (custom-declare-variable): + * custom.el (defcustom): + * custom.el (custom-current-group): New. + * custom.el (custom-declare-group): + * custom.el (defgroup): + * custom.el (custom-add-to-group): + * custom.el (custom-group-of-mode): New. + * custom.el (custom-handle-all-keywords): + * custom.el (custom-autoload): New. + * custom.el (custom-variable-p): New. + * custom.el (custom-load-recursion): New. + * custom.el (custom-load-symbol): New. + * custom.el (custom-known-themes): + * custom.el (custom-declare-theme): New. + * custom.el (deftheme): + * custom.el (custom-make-theme-feature): + * custom.el (custom-check-theme): + * custom.el (custom-push-theme): + * custom.el (custom-set-variables): + * custom.el (custom-theme-set-variables): + * custom.el (custom-set-default): New. + * custom.el (custom-quote): New. + * custom.el (customize-mark-to-save): New. + * custom.el (provide-theme): + * custom.el (require-theme): + * custom.el (customize-mark-as-set): New. + * custom.el (custom-remove-theme): New. + * custom.el (custom-do-theme-reset): + * custom.el (custom-theme-load-themes): + * custom.el (custom-load-themes): + * custom.el (custom-theme-value): + * custom.el (custom-theme-variable-value): + * custom.el (custom-theme-reset-internal): + * custom.el (copy-upto-last): Removed. + * custom.el (custom-theme-reset-variables): + * custom.el (custom-reset-variables): + Sync with FSF 21.3. + +2004-11-09 Ben Wing <ben(a)xemacs.org> + + * easy-mmode.el, regexp-opt.el: + Move these files into core. + Uncomment stuff depending on new custom.el. + + * autoload.el: + * autoload.el (generate-autoload-function): New. + * autoload.el (autoload-feature-suffix): New. + * autoload.el (generate-autoload-section-continuation): New. + * autoload.el (make-autoload): + * autoload.el (generate-file-autoloads): + * autoload.el (generate-autoload-type-section): + * autoload.el (process-one-lisp-autoload): New. + * autoload.el (generate-lisp-file-autoloads-1): + * autoload.el (generate-c-file-autoloads-1): + * autoload.el (generate-custom-defines): New. + * autoload.el (print-autoload): Removed. + * autoload.el (autoload-print-form): New. + * autoload.el (defcustom): + * autoload.el (autoload-read-section-header): New. + * autoload.el (update-file-autoloads): + * autoload.el (update-autoloads-here): Removed. + * autoload.el (batch-update-directory-custom-defines): New. + * autoload.el (update-autoload-files): + * autoload.el (autoload-update-directory-autoloads): Removed. + * autoload.el (batch-update-directory-autoloads): New. + * autoload.el (autoload-featurep-protect-autoloads): + * autoload.el (update-autoloads-from-directory): Removed. + * autoload.el (update-custom-define-files): New. + * autoload.el (autoload-make-feature-name): + * autoload.el (batch-update-autoloads): + * autoload.el (batch-update-directory): Removed. + * autoload.el (batch-update-one-directory): Removed. + * autoload.el (batch-force-update-one-directory): Removed. + Major update. Sync with FSF 21.2. + Create the ability to make custom-defines files. + + * behavior-defs.el: + * behavior-defs.el (tty): + * behavior-defs.el ('scroll-in-place): Removed. + * behavior-defs.el ('mouse-avoidance): Removed. + * behavior-defs.el ('jka-compr): Removed. + * behavior-defs.el ('efs): Removed. + * behavior-defs.el ('resize-minibuffer): Removed. + * behavior-defs.el ('func-menu): Removed. + * behavior-defs.el ('mwheel): Removed. + * behavior-defs.el ('recent-files): Removed. + * behavior-defs.el ('filladapt): Removed. + * behavior-defs.el ('tty)): New. + * behavior-defs.el ('toolbars)): New. + * behavior-defs.el ('menus)): New. + * behavior-defs.el ('mouse)): New. + * behavior-defs.el ('editing)): New. + * behavior-defs.el ('keyboard)): New. + * behavior-defs.el ('files)): New. + * behavior-defs.el ('games)): New. + * behavior-defs.el ('processes)): New. + * behavior-defs.el ('display)): New. + * behavior-defs.el ('programming)): New. + * behavior-defs.el ('international)): New. + * behavior-defs.el ('buffers-and-windows)): New. + * behavior-defs.el ('internet)): New. + * behavior-defs.el ('compose-mail): New. + Only define the basic behavior groups here. + Move the definitions for particular packages to the + appropriate package files. + + * behavior.el: + * behavior.el (behavior-group-hash-table): New. + * behavior.el (behavior-override-hash-table): New. + * behavior.el (define-behavior): Removed. + * behavior.el (behavior-group-p): New. + * behavior.el (check-behavior-group): New. + * behavior.el (override-behavior): + * behavior.el (define-behavior-group): + * behavior.el (read-behavior): + * behavior.el (compute-behavior-group-children): New. + * behavior.el (behavior-menu-filter-1): New. + * behavior.el (behavior-menu-filter): New. + Major update. Add documentation of how it works. + + * easymenu.el (easy-menu-add): + * easymenu.el (easy-menu-remove): + * map-ynp.el (map-y-or-n-p): + Use normalize-menu-text not normalize-menu-item-name. + + * menubar-items.el (submenu-generate-accelerator-spec): Removed. + * menubar.el (submenu-generate-accelerator-spec): New. + Move to menubar.el and rewrite for cleanliness. + + * menubar-items.el (coding-system-menu-filter): + Use menu-split-long-menu-and-sort. + + * menubar-items.el (menu-item-strip-accelerator-spec): Removed. + * menubar-items.el (menu-item-generate-accelerator-spec): Removed. + * menubar-items.el (menu-max-items): Removed. + * menubar-items.el (menu-submenu-max-items): Removed. + * menubar-items.el (menu-submenu-name-format): Removed. + * menubar-items.el (menu-split-long-menu): Removed. + * menubar-items.el (menu-sort-menu): Removed. + * menubar.el (menu-item-strip-accelerator-spec): New. + * menubar.el (menu-item-generate-accelerator-spec): New. + * menubar.el (menu-max-items): New. + * menubar.el (menu-submenu-max-items): New. + * menubar.el (menu-submenu-name-format): New. + * menubar.el (menu-split-long-menu): New. + * menubar.el (menu-sort-menu): New. + Move to menubar.el. + + * menubar.el (menu-item-text): New. + * menubar.el (menu-split-long-menu-and-sort): New. + New funs. + + * menubar-items.el (default-menubar): + Delete many menus from Tools menu -- they have been integrated + as part of the behavior system. + + Delete old Behavior menu defn. Use behavior-menu-filter. + + Use menu-split-long-menu-and-sort. + + * menubar.el (find-menu-item): + * menubar.el (find-menu-item-1): New. + Split up find-menu-item w/find-menu-item-1, since PARENT is not + an external item. + Rewrite to use compare-menu-text. + + * menubar.el (add-menu-item-1): + Don't normalize items as find-menu-item does not need it. + + * mwheel.el: + * mwheel.el ('mwheel): New. + Add define-behavior for mwheel. + + * paragraphs.el: + * paragraphs.el (paragraphs): New. + * paragraphs.el (use-hard-newlines): Removed. + * paragraphs.el (paragraph-start): + * paragraphs.el (paragraph-separate): + * paragraphs.el (sentence-end-double-space): New. + * paragraphs.el (sentence-end-without-period): New. + * paragraphs.el (sentence-end): + * paragraphs.el (forward-paragraph): + * paragraphs.el (backward-paragraph): + * paragraphs.el (mark-paragraph): + * paragraphs.el (forward-sentence): + * paragraphs.el (mark-end-of-sentence): + * paragraphs.el (transpose-sentences): + Sync to 21.3. Depends on easy-mmode in core. + + * update-elc-2.el (batch-update-elc-2): + * update-elc.el (do-autoload-commands): + Rewrite to use new autoload API. + + * update-elc.el (lisp-files-needing-early-byte-compilation): + Add easy-mmode. + 2005-01-31 Ben Wing <ben(a)xemacs.org> * help.el: 1.10 +2 -5 XEmacs/xemacs/lisp/cus-dep.el (In the diff below, changes in quantity of whitespace are not shown.) Index: cus-dep.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/cus-dep.el,v retrieving revision 1.9 retrieving revision 1.10 diff -u -b -r1.9 -r1.10 --- cus-dep.el 2003/02/14 12:05:07 1.9 +++ cus-dep.el 2005/02/03 04:29:33 1.10 ＠＠ -173,11 +173,8 ＠＠ )) (cond ((zerop (hash-table-count hash)) - (if (not (file-exists-p cusload-file)) (message "(No customization dependencies)") - (message "(No customization dependencies, deleting %s)" - cusload-file) - (delete-file cusload-file))) + (write-region "" nil cusload-file)) (t (message "Generating %s...\n" cusload-base-file) (with-temp-file cusload-file 1.23 +143 -42 XEmacs/xemacs/lisp/cus-edit.el (In the diff below, changes in quantity of whitespace are not shown.) Index: cus-edit.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/cus-edit.el,v retrieving revision 1.22 retrieving revision 1.23 diff -u -b -r1.22 -r1.23 --- cus-edit.el 2004/06/10 12:20:01 1.22 +++ cus-edit.el 2005/02/03 04:29:33 1.23 ＠＠ -1,6 +1,7 ＠＠ ;;; cus-edit.el --- Tools for customizating Emacs and Lisp packages. ;; ;; Copyright (C) 1996, 1997, 2000 Free Software Foundation, Inc. +;; Copyright (C) 2003 Ben Wing. ;; ;; Author: Per Abrahamsen <abraham(a)dina.kvl.dk> ;; Maintainer: Hrvoje Niksic <hniksic(a)xemacs.org> ＠＠ -1656,6 +1657,9 ＠＠ (while loads (setq load (car loads) loads (cdr loads)) + (custom-load-symbol-1 load))))) + +(defun custom-load-symbol-1 (load) (cond ((symbolp load) (condition-case nil (require load) ＠＠ -1672,7 +1676,102 ＠＠ ;; and it is not in load-history yet. (or (equal load "cus-edit") (load-library load)) - (error nil)))))))) + (error nil))))) + +(defvar custom-already-loaded-custom-defines nil + "List of already-loaded `custom-defines' files.") +(defvar custom-define-current-source-file nil) +(defvar custom-warn-when-reloading-necessary nil + "For package-debugging purposes: Warn when an error hit in custom-defines.el. +When this happens, the file from which the defcustom or defgroup was taken +is loaded, and custom-defines.el is then reloaded. This works in most +cases, but may not be completely safe. It's better if the package itself +arranges for the necessary functions and variables to be available, using +\;;;###autoload declarations. When this variable is non-nil, warnings are +issued (with backtrace), to aid in tracking down the problems.") + +(defun custom-load-custom-defines (symbol) + "Load custom-defines for SYMBOL." + (unless custom-load-recursion + (let ((custom-load-recursion t) + (loads (get symbol 'custom-loads)) + load) + (while loads + (setq load (car loads) + loads (cdr loads)) + (let* ((found (locate-library + (if (symbolp load) (symbol-name load) load))) + (dir (and found (file-name-directory found)))) + ;; If we find a custom-defines file, assume the package is smart + ;; enough to have put all its defcustoms and defgroups here, and + ;; load it instead of the file itself. Otherwise, do it the + ;; hard way. + (if (and found (or (file-exists-p + (expand-file-name "custom-defines.elc" dir)) + (file-exists-p + (expand-file-name "custom-defines.el" dir)))) + (when (not (member dir custom-already-loaded-custom-defines)) + (push dir custom-already-loaded-custom-defines) + (custom-load-custom-defines-1 dir)))))))) + +(defun custom-load-custom-defines-1 (dir) + ;; Actually load the custom-defines.el file in DIR. + + ;; If we get an error loading the custom-defines, it may be because of a + ;; reference to something (e.g. a constant) that hasn't yet been defined + ;; yet. Properly, these should have been marked, so they either go into + ;; the custom-defines.el file or are autoloaded. But not everyone is so + ;; careful, so for the moment we try to load the file that the + ;; error-generating defcustom came from, and then reload the + ;; custom-defines.el file. We might loop a number of times if we have + ;; various files that need loading. If at any point we get an error that + ;; can't be solved just by loading the appropriate file (e.g. we hit the + ;; same error as before, the file is already loaded, etc.) then we signal + ;; it as a real error. + (let (source) + ;; here's how this works: if we get an error loading custom-defines, + ;; the condition handler is called; if we need to reload, we + ;; `return-from', which throws out of the handler and returns nil from + ;; the `block', which continues the while statement, executing the + ;; `load' at the bottom of this function and then entering the block + ;; again. if the condition handler doesn't throw, but instead returns + ;; normally, `signal' will continue as if nothing happened, and end up + ;; signalling the error normally. + (while + (not + (block custom-load + ;; Use call-with-condition-handler so the error can be seen + ;; with the stack intact. + (call-with-condition-handler + #'(lambda (__custom_load_cd1__) + (when (and + custom-define-current-source-file + (progn + (setq source (expand-file-name + custom-define-current-source-file + dir)) + (let ((nondir (file-name-nondirectory source))) + (and (file-exists-p source) + (not (assoc source load-history)) + (not (assoc nondir load-history)) + (not (and (boundp 'preloaded-file-list) + (member nondir + preloaded-file-list))))))) + (if custom-warn-when-reloading-necessary + (lwarn 'custom-defines 'warning + "Error while loading custom-defines, fetching source and reloading ...\n +Error: %s\n +Source file: %s\n\n +Backtrace follows:\n\n%s" + (error-message-string __custom_load_cd1__) + source + (backtrace-in-condition-handler-eliminating-handler + '__custom_load_cd1__))) + (return-from custom-load nil))) + #'(lambda () + (load (expand-file-name "custom-defines" dir)))))) + ;; we get here only from the `return-from'; see above + (load source)))) (defun custom-load-widget (widget) "Load all dependencies for WIDGET." ＠＠ -3709,13 +3808,14 ＠＠ (defun custom-menu-create (symbol) "Create menu for customization group SYMBOL. The menu is in a format applicable to `easy-menu-define'." + (menu-split-long-menu (let* ((item (vector (custom-unlispify-menu-entry symbol) `(customize-group ',symbol) t))) ;; Item is the entry for creating a menu buffer for SYMBOL. ;; We may nest, if the menu is not too big. - (custom-load-symbol symbol) - (if (< (length (get symbol 'custom-group)) widget-menu-max-size) + (custom-load-custom-defines symbol) + (if t ;(< (length (get symbol 'custom-group)) widget-menu-max-size) ;; The menu is not too big. (let ((custom-prefix-list (custom-prefix-add symbol custom-prefix-list)) ＠＠ -3732,8 +3832,9 ＠＠ (list (nth 1 entry))) :custom-menu (nth 0 entry))) members))) - ;; The menu was too big. - item))) + ; else ;; The menu was too big. + item + )))) ;;;###autoload (defun customize-menu-create (symbol &optional name) 1.13 +583 -265 XEmacs/xemacs/lisp/custom.el (In the diff below, changes in quantity of whitespace are not shown.) Index: custom.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/custom.el,v retrieving revision 1.12 retrieving revision 1.13 diff -u -b -r1.12 -r1.13 --- custom.el 2003/03/03 10:17:40 1.12 +++ custom.el 2005/02/03 04:29:33 1.13 ＠＠ -1,12 +1,10 ＠＠ -;;; custom.el -- Tools for declaring and initializing options. - -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. - +;;; custom.el --- tools for declaring and initializing options +;; +;; Copyright (C) 1996, 1997, 1999, 2001, 2002 Free Software Foundation, Inc. +;; ;; Author: Per Abrahamsen <abraham(a)dina.kvl.dk> -;; Maintainer: Hrvoje Niksic <hniksic(a)xemacs.org> +;; Maintainer: XEmacs Development Group ;; Keywords: help, faces, dumped -;; Version: 1.9960-x -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; This file is part of XEmacs. ＠＠ -25,17 +23,18 ＠＠ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. -;;; Synched with: ??? Partially synched to 21.2 by Ben Wing. +;;; Synched with: FSF 21.3. ;;; Commentary: ;; This file is dumped with XEmacs. -;; This file only contain the code needed to declare and initialize -;; user options. The code to customize options is autoloaded from -;; `cus-edit.el'. ;; -;; The code implementing face declarations is in `cus-face.el' +;; This file only contains the code needed to declare and initialize +;; user options. The code to customize options is autoloaded from +;; `cus-edit.el' and is documented in the XEmacs Lisp Reference manual. + +;; The code implementing face declarations is in `cus-face.el'. ;;; Code: ＠＠ -44,8 +43,6 ＠＠ ;; prevent require/provide loop with custom and cus-face. (provide 'custom) -;; BEGIN SYNC WITH FSF 21.2 - (eval-when-compile (load "cl-macs" nil t) ;; To elude warnings. ＠＠ -60,6 +57,14 ＠＠ ;; Customize information for this option is in `cus-edit.el'. "Hook called after defining each customize option.") +(defvar custom-dont-initialize nil + "Non-nil means `defcustom' should not initialize the variable. +That is used for the sake of `custom-make-dependencies'. +Users should not set it.") + +(defvar custom-current-group-alist nil + "Alist of (FILE . GROUP) indicating the current group to use for FILE.") + ;;; The `defcustom' Macro. (defun custom-initialize-default (symbol value) ＠＠ -131,8 +136,16 ＠＠ (defun custom-declare-variable (symbol default doc &rest args) "Like `defcustom', but SYMBOL and DEFAULT are evaluated as normal arguments. DEFAULT should be an expression to evaluate to compute the default value, -not the default value itself." - ;; Remember the standard setting. +not the default value itself. + +DEFAULT is stored as SYMBOL's value in the standard theme. See +`custom-known-themes' for a list of known themes. For backwards +compatibility, DEFAULT is also stored in SYMBOL's property +`standard-value'. At the same time, SYMBOL's property `force-value' is +set to nil, as the value is no longer rogue." + ;; Remember the standard setting. The value should be in the standard + ;; theme, not in this property. However, his would require changeing + ;; the C source of defvar and others as well... (put symbol 'standard-value (list default)) ;; Maybe this option was rogue in an earlier version. It no longer is. (when (eq (get symbol 'force-value) 'rogue) ＠＠ -142,6 +155,8 ＠＠ (put symbol 'variable-documentation doc)) (let ((initialize 'custom-initialize-reset) (requests nil)) + (unless (memq :group args) + (custom-add-to-group (custom-current-group) symbol 'custom-variable)) (while args (let ((arg (car args))) (setq args (cdr args)) ＠＠ -158,9 +173,9 ＠＠ ((eq keyword :get) (put symbol 'custom-get value)) ((eq keyword :require) - (setq requests (cons value requests))) + (push value requests)) ((eq keyword :type) - (put symbol 'custom-type value)) + (put symbol 'custom-type (purecopy value))) ((eq keyword :options) (if (get symbol 'custom-options) ;; Slow safe code to avoid duplicates. ＠＠ -174,10 +189,11 ＠＠ 'custom-variable)))))) (put symbol 'custom-requests requests) ;; Do the actual initialization. - (funcall initialize symbol default)) + (unless custom-dont-initialize + (funcall initialize symbol default))) ;; #### This is a rough equivalent of LOADHIST_ATTACH. However, ;; LOADHIST_ATTACH also checks for `initialized'. - (push symbol current-load-list) + (push (cons 'defvar symbol) current-load-list) (run-hooks 'custom-define-hook) symbol) ＠＠ -193,16 +209,43 ＠＠ The following keywords are meaningful: -:type VALUE should be a widget type for editing the symbols value. +:type VALUE should be a widget type for editing the symbol's value. The default is `sexp'. :options VALUE should be a list of valid members of the widget type. :group VALUE should be a customization group. Add SYMBOL to that group. +:link LINK-DATA + Include an external link after the documentation string for this + item. This is a sentence containing an active field which + references some other documentation. + + There are three alternatives you can use for LINK-DATA: + + (custom-manual INFO-NODE) + Link to an Info node; INFO-NODE is a string which specifies + the node name, as in \"(emacs)Top\". The link appears as + `[manual]' in the customization buffer. + + (info-link INFO-NODE) + Like `custom-manual' except that the link appears in the + customization buffer with the Info node name. + + (url-link URL) + Link to a web page; URL is a string which specifies the URL. + The link appears in the customization buffer as URL. + + You can specify the text to use in the customization buffer by + adding `:tag NAME' after the first element of the LINK-DATA; for + example, (info-link :tag \"foo\" \"(emacs)Top\") makes a link to the + Emacs manual which appears in the buffer as `foo'. + + An item can have more than one external link; however, most items + have none at all. :initialize VALUE should be a function used to initialize the variable. It takes two arguments, the symbol and value given in the `defcustom' call. The default is - `custom-initialize-reset' + `custom-initialize-reset'. :set VALUE should be a function to set the value of the symbol. It takes two arguments, the symbol to set and the value to give it. The default choice of function is `custom-set-default'. ＠＠ -219,16 +262,21 ＠＠ VALUE should be a string specifying that the variable was first introduced, or its default value was changed, in Emacs version VERSION. -:set-after VARIABLE - Specifies that SYMBOL should be set after VARIABLE when - both have been customized. +:tag LABEL + Use LABEL, a string, instead of the item's name, to label the item + in customization menus and buffers. +:load FILE + Load file FILE (a string) before displaying this customization + item. Loading is done with `load', and only if the file is + not already loaded. +:set-after VARIABLES + Specifies that SYMBOL should be set after the list of variables + VARIABLES when both have been customized. Read the section about customization in the Emacs Lisp manual for more information." `(custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,＠args)) -;; END SYNC WITH FSF 21.2 - ;;; The `defface' Macro. (defmacro defface (face spec doc &rest args) ＠＠ -278,12 +326,14 ＠＠ ;;; The `defgroup' Macro. +(defun custom-current-group () + (cdr (assoc load-file-name custom-current-group-alist))) + (defun custom-declare-group (symbol members doc &rest args) "Like `defgroup', but SYMBOL is evaluated as a normal argument." (while members (apply 'custom-add-to-group symbol (car members)) (pop members)) - (put symbol 'custom-group (nconc members (get symbol 'custom-group))) (when doc (put symbol 'group-documentation doc)) (while args ＠＠ -300,6 +350,10 ＠＠ (t (custom-handle-keyword symbol keyword value 'custom-group)))))) + ;; Record the group on the `current' list. + (let ((elt (assoc load-file-name custom-current-group-alist))) + (if elt (setcdr elt symbol) + (push (cons load-file-name symbol) custom-current-group-alist))) (run-hooks 'custom-define-hook) symbol) ＠＠ -318,13 +372,24 ＠＠ [KEYWORD VALUE]... -The following KEYWORD's are defined: +The following KEYWORDs are defined: :group VALUE should be a customization group. Add SYMBOL to that group. Read the section about customization in the Emacs Lisp manual for more information." + + ;; XEmacs: Evidently a purposeful omission from the docs: +;:version VALUE should be a string specifying that the group was introduced +; in Emacs version VERSION. +; + + ;; FSF: (not a problem for XEmacs) + ;; It is better not to use backquote in this file, + ;; because that makes a bootstrapping problem + ;; if you need to recompile all the Lisp files using interpreted code. +; (nconc (list 'custom-declare-group (list 'quote symbol) members doc) args)) `(custom-declare-group (quote ,symbol) ,members ,doc ,＠args)) (defvar custom-group-hash-table (make-hash-table :size 300 :test 'eq) ＠＠ -332,19 +397,31 ＠＠ (defun custom-add-to-group (group option widget) "To existing GROUP add a new OPTION of type WIDGET. -If there already is an entry for that option, overwrite it." - (let* ((members (get group 'custom-group)) - (old (assq option members))) - (if old - (setcar (cdr old) widget) - (put group 'custom-group (nconc members (list (list option widget)))))) +If there already is an entry for OPTION and WIDGET, nothing is done." + (let ((members (get group 'custom-group)) + (entry (list option widget))) + (unless (member entry members) + (put group 'custom-group (nconc members (list entry))))) (puthash group t custom-group-hash-table)) +(defun custom-group-of-mode (mode) + "Return the custom group corresponding to the major or minor MODE. +If no such group is found, return nil." + (or (get mode 'custom-mode-group) + (if (or (get mode 'custom-group) + (and (string-match "-mode\\'" (symbol-name mode)) + (get (setq mode (intern (substring (symbol-name mode) + 0 (match-beginning 0)))) + 'custom-group))) + mode))) + ;;; Properties. (defun custom-handle-all-keywords (symbol args type) "For customization option SYMBOL, handle keyword arguments ARGS. Third argument TYPE is the custom option type." + (unless (memq :group args) + (custom-add-to-group (custom-current-group) symbol type)) (while args (let ((arg (car args))) (setq args (cdr args)) ＠＠ -420,78 +497,195 ＠＠ (unless (member load loads) (put symbol 'custom-loads (cons load loads))))) -;;; deftheme macro +(defun custom-autoload (symbol load) + "Mark SYMBOL as autoloaded custom variable and add dependency LOAD." + (put symbol 'custom-autoload t) + (custom-add-load symbol load)) + +;; This test is also in the C code of `user-variable-p'. +(defun custom-variable-p (variable) + "Return non-nil if VARIABLE is a custom variable." + (or (get variable 'standard-value) + (get variable 'custom-autoload))) + +;;; Loading files needed to customize a symbol. +;;; This is in custom.el because menu-bar.el needs it for toggle cmds. + +(defvar custom-load-recursion nil + "Hack to avoid recursive dependencies.") + +(defun custom-load-symbol (symbol) + "Load all dependencies for SYMBOL." + (unless custom-load-recursion + (let ((custom-load-recursion t)) + (dolist (load (get symbol 'custom-loads)) + (cond ((symbolp load) (condition-case nil (require load) (error nil))) + ;; This is subsumed by the test below, but it's much faster. + ((assoc load load-history)) + ;; This was just (assoc (locate-library load) load-history) + ;; but has been optimized not to load locate-library + ;; if not necessary. + ((let ((regexp (concat "\$\\`\\|/\$" (regexp-quote load) + "\$\\'\\|\\.\$")) + (found nil)) + (dolist (loaded load-history) + (and (stringp (car loaded)) + (string-match regexp (car loaded)) + (setq found t))) + found)) + ;; Without this, we would load cus-edit recursively. + ;; We are still loading it when we call this, + ;; and it is not in load-history yet. + ((equal load "cus-edit")) + (t (condition-case nil (load load) (error nil)))))))) (defvar custom-known-themes '(user standard) - "Themes that have been defthemed.") - -;; #### add strings for group -;; #### during bootstrap we cannot use cl-macs stuff -(defun* custom-define-theme (theme feature &optional doc - &key short-description immediate variable-reset-string - variable-set-string face-set-string face-reset-string - &allow-other-keys) - (push theme custom-known-themes) + "Themes that have been define with `deftheme'. +The default value is the list (user standard). The theme `standard' +contains the Emacs standard settings from the original Lisp files. The +theme `user' contains all the the settings the user customized and saved. +Additional themes declared with the `deftheme' macro will be added to +the front of this list.") + +(defun custom-declare-theme (theme feature &optional doc &rest args) + "Like `deftheme', but THEME is evaluated as a normal argument. +FEATURE is the feature this theme provides. This symbol is created +from THEME by `custom-make-theme-feature'." + (add-to-list 'custom-known-themes theme) (put theme 'theme-feature feature) - (put theme 'theme-documentation doc) - (if immediate (put theme 'theme-immediate immediate)) - (if variable-reset-string - (put theme 'theme-variable-reset-string variable-reset-string )) - (if variable-set-string - (put theme 'theme-variable-set-string variable-set-string )) - (if face-reset-string - (put theme 'theme-face-reset-string face-reset-string )) - (if face-set-string - (put theme 'theme-face-set-string face-set-string )) - (if short-description - (put theme 'theme-short-description short-description ))) + (when doc + (put theme 'theme-documentation doc)) + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (check-argument-type 'keywordp arg) + (let ((keyword arg) + (value (car args))) + (unless args + (signal 'error (list "Keyword is missing an argument" keyword))) + (setq args (cdr args)) + (cond ((eq keyword :short-description) + (put theme 'theme-short-description value)) + ((eq keyword :immediate) + (put theme 'theme-immediate value)) + ((eq keyword :variable-set-string) + (put theme 'theme-variable-set-string value)) + ((eq keyword :variable-reset-string) + (put theme 'theme-variable-reset-string value)) + ((eq keyword :face-set-string) + (put theme 'theme-face-set-string value)) + ((eq keyword :face-reset-string) + (put theme 'theme-face-reset-string value))))))) + +(defmacro deftheme (theme &optional doc &rest args) + "Declare custom theme THEME. +The optional argument DOC is a doc string describing the theme. +The remaining arguments should have the form -(defun custom-make-theme-feature (theme) - (intern (concat (symbol-name theme) "-theme"))) + [KEYWORD VALUE]... -(defmacro deftheme (theme &rest body) - "(deftheme THEME &optional DOC &key KEYWORDS) +The following KEYWORD's are defined: -Define a theme labeled by SYMBOL THEME. The optional argument DOC is a -doc string describing the theme. It is optionally followed by the -following keyword arguments - -:short-description DESC - DESC is a short (one line) description of the theme. If not given DOC - is used. -:immediate FLAG - If FLAG is non-nil variables set in this theme are bound +:short-description + VALUE is a short (one line) description of the theme. If not + given, DOC is used. +:immediate + If VALUE is non-nil, variables specified in this theme are set immediately when loading the theme. -:variable-set-string VARIABLE_-SET-STRING - A string used by the UI to indicate that the value takes it - setting from this theme. It is passed to FORMAT with the - name of the theme a additional argument. - If not given, a generic description is used. -:variable-reset-string VARIABLE-RESET-STRING - As above but used in the case the variable has been forced to - the value in this theme. -:face-set-string FACE-SET-STRING -:face-reset-string FACE-RESET-STRING - As above but for faces." +:variable-set-string + VALUE is a string used to indicate that a variable takes its + setting from this theme. It is passed to FORMAT with the name + of the theme as an additional argument. If not given, a + generic description is used. +:variable-reset-string + VALUE is a string used in the case a variable has been forced + to its value in this theme. It is passed to FORMAT with the + name of the theme as an additional argument. If not given, a + generic description is used. +:face-set-string + VALUE is a string used to indicate that a face takes its + setting from this theme. It is passed to FORMAT with the name + of the theme as an additional argument. If not given, a + generic description is used. +:face-reset-string + VALUE is a string used in the case a face has been forced to + its value in this theme. It is passed to FORMAT with the name + of the theme as an additional argument. If not given, a + generic description is used. + +Any theme `foo' should be defined in a file called `foo-theme.el'; +see `custom-make-theme-feature' for more information." (let ((feature (custom-make-theme-feature theme))) - `(custom-define-theme (quote ,theme) (quote ,feature) ,＠body))) + ;; It is better not to use backquote in this file, + ;; because that makes a bootstrapping problem + ;; if you need to recompile all the Lisp files using interpreted code. + (nconc (list 'custom-declare-theme + (list 'quote theme) + (list 'quote feature) + doc) args))) + +(defun custom-make-theme-feature (theme) + "Given a symbol THEME, create a new symbol by appending \"-theme\". +Store this symbol in the `theme-feature' property of THEME. +Calling `provide-theme' to provide THEME actually puts `THEME-theme' +into `features'. + +This allows for a file-name convention for autoloading themes: +Every theme X has a property `provide-theme' whose value is \"X-theme\". +\(require-theme X) then attempts to load the file `X-theme.el'." + (intern (concat (symbol-name theme) "-theme"))) (defsubst custom-theme-p (theme) "Non-nil when THEME has been defined." (memq theme custom-known-themes)) (defsubst custom-check-theme (theme) - "Check whether THEME is valid and signal an error if NOT." + "Check whether THEME is valid, and signal an error if it is not." (unless (custom-theme-p theme) (error "Unknown theme `%s'" theme))) - -; #### do we need to deftheme 'user and/or 'standard here to make the -; code in cus-edit cleaner?. - ;;; Initializing. (defun custom-push-theme (prop symbol theme mode value) + "Add (THEME MODE VALUE) to the list in property PROP of SYMBOL. +If the first element in that list is already (THEME ...), +discard it first. + +MODE can be either the symbol `set' or the symbol `reset'. If it is the +symbol `set', then VALUE is the value to use. If it is the symbol +`reset', then VALUE is the mode to query instead. + +In the following example for the variable `goto-address-url-face', the +theme `subtle-hacker' uses the same value for the variable as the theme +`gnome2': + + \((standard set bold) + \(gnome2 set info-xref) + \(jonadab set underline) + \(subtle-hacker reset gnome2)) + + +If a value has been stored for themes A B and C, and a new value +is to be stored for theme C, then the old value of C is discarded. +If a new value is to be stored for theme B, however, the old value +of B is not discarded because B is not the car of the list. + +For variables, list property PROP is `theme-value'. +For faces, list property PROP is `theme-face'. +This is used in `custom-do-theme-reset', for example. + +The list looks the same in any case; the examples shows a possible +value of the `theme-face' property for the face `region': + + \((gnome2 set ((t (:foreground \"cyan\" :background \"dark cyan\")))) + \(standard set ((((class color) (background dark)) + \(:background \"blue\")) + \(t (:background \"gray\"))))) + +This records values for the `standard' and the `gnome2' themes. +The user has not customized the face; had he done that, +the list would contain an entry for the `user' theme, too. +See `custom-known-themes' for a list of known themes." (let ((old (get symbol prop))) (if (eq (car-safe (car-safe old)) theme) (setq old (cdr old))) ＠＠ -508,13 +702,14 ＠＠ (defun custom-set-variables (&rest args) "Initialize variables according to user preferences. The settings are registered as theme `user'. -Each argument should be a list of the form: +The arguments should each be a list of the form: (SYMBOL VALUE [NOW [REQUEST [COMMENT]]]) The unevaluated VALUE is stored as the saved value for SYMBOL. If NOW is present and non-nil, VALUE is also evaluated and bound as the default value for the SYMBOL. + REQUEST is a list of features we must 'require for SYMBOL. COMMENT is a comment string about SYMBOL." (apply 'custom-theme-set-variables 'user args)) ＠＠ -522,9 +717,30 ＠＠ (defun custom-theme-set-variables (theme &rest args) "Initialize variables according to settings specified by args. Records the settings as belonging to THEME. + +The arguments should be a list where each entry has the form: + + (SYMBOL VALUE [NOW [REQUEST [COMMENT]]]) + +The unevaluated VALUE is stored as the saved value for SYMBOL. +If NOW is present and non-nil, VALUE is also evaluated and bound as +the default value for the SYMBOL. +REQUEST is a list of features we must 'require for SYMBOL. +COMMENT is a comment string about SYMBOL. + +Several properties of THEME and SYMBOL are used in the process: + +If THEME property `theme-immediate' is non-nil, this is equivalent of +providing the NOW argument to all symbols in the argument list: SYMBOL +is bound to the evaluated VALUE. The only difference is SYMBOL property +`force-value': if NOW is non-nil, SYMBOL's property `force-value' is set to +the symbol `rogue', else if THEME's property `theme-immediate' is non-nil, +FACE's property `force-face' is set to the symbol `immediate'. -See `custom-set-variables' for a description of the arguments ARGS." +VALUE itself is saved unevaluated as SYMBOL property `saved-value' and +in SYMBOL's list property `theme-value' \(using `custom-push-theme')." (custom-check-theme theme) + (let ((immediate (get theme 'theme-immediate))) (setq args (sort args (lambda (a1 a2) ＠＠ -535,7 +751,6 ＠＠ (cond ((and 1-then-2 2-then-1) (error "Circular custom dependency between `%s' and `%s'" sym1 sym2)) - (1-then-2 t) (2-then-1 nil) ;; Put symbols with :require last. The macro ;; define-minor-mode generates a defcustom ＠＠ -546,7 +761,6 ＠＠ ;; customized values rather than default ;; values. (t (nth 3 a2))))))) - (let ((immediate (get theme 'theme-immediate))) (while args (let ((entry (car args))) (if (listp entry) ＠＠ -555,10 +769,14 ＠＠ (now (nth 2 entry)) (requests (nth 3 entry)) (comment (nth 4 entry)) - (set (or (get symbol 'custom-set) 'custom-set-default))) + set) + (when requests + (put symbol 'custom-requests requests) + (mapc 'require requests)) + (setq set (or (get symbol 'custom-set) 'custom-set-default)) (put symbol 'saved-value (list value)) - (custom-push-theme 'theme-value symbol theme 'set value) (put symbol 'saved-variable-comment comment) + (custom-push-theme 'theme-value symbol theme 'set value) ;; Allow for errors in the case where the setter has ;; changed between versions, say, but let the user know. (condition-case data ＠＠ -571,12 +789,9 ＠＠ (funcall set symbol (eval value)))) (error (message "Error setting %s: %s" symbol data))) + (setq args (cdr args)) (and (or now (default-boundp symbol)) - (put symbol 'variable-comment comment)) - (when requests - (put symbol 'custom-requests requests) - (mapc 'require requests)) - (setq args (cdr args))) + (put symbol 'variable-comment comment))) ;; Old format, a plist of SYMBOL VALUE pairs. (message "Warning: old format `custom-set-variables'") (ding) ＠＠ -587,6 +802,85 ＠＠ (custom-push-theme 'theme-value symbol theme 'set value)) (setq args (cdr (cdr args)))))))) +(defun custom-set-default (variable value) + "Default :set function for a customizable variable. +Normally, this sets the default value of VARIABLE to VALUE, +but if `custom-local-buffer' is non-nil, +this sets the local binding in that buffer instead." + (if custom-local-buffer + (with-current-buffer custom-local-buffer + (set variable value)) + (set-default variable value))) + +(defun custom-quote (sexp) + "Quote SEXP iff it is not self quoting." + (if (or (memq sexp '(t nil)) + (keywordp sexp) + (and (listp sexp) + (memq (car sexp) '(lambda))) + (stringp sexp) + (numberp sexp) + (vectorp sexp) +;;; (and (fboundp 'characterp) +;;; (characterp sexp)) + ) + sexp + (list 'quote sexp))) + +(defun customize-mark-to-save (symbol) + "Mark SYMBOL for later saving. + +If the default value of SYMBOL is different from the standard value, +set the `saved-value' property to a list whose car evaluates to the +default value. Otherwise, set it to nil. + +To actually save the value, call `custom-save-all'. + +Return non-nil iff the `saved-value' property actually changed." + (let* ((get (or (get symbol 'custom-get) 'default-value)) + (value (funcall get symbol)) + (saved (get symbol 'saved-value)) + (standard (get symbol 'standard-value)) + (comment (get symbol 'customized-variable-comment))) + ;; Save default value iff different from standard value. + (if (or (null standard) + (not (equal value (condition-case nil + (eval (car standard)) + (error nil))))) + (put symbol 'saved-value (list (custom-quote value))) + (put symbol 'saved-value nil)) + ;; Clear customized information (set, but not saved). + (put symbol 'customized-value nil) + ;; Save any comment that might have been set. + (when comment + (put symbol 'saved-variable-comment comment)) + (not (equal saved (get symbol 'saved-value))))) + +(defun customize-mark-as-set (symbol) + "Mark current value of SYMBOL as being set from customize. + +If the default value of SYMBOL is different from the saved value if any, +or else if it is different from the standard value, set the +`customized-value' property to a list whose car evaluates to the +default value. Otherwise, set it to nil. + +Return non-nil iff the `customized-value' property actually changed." + (let* ((get (or (get symbol 'custom-get) 'default-value)) + (value (funcall get symbol)) + (customized (get symbol 'customized-value)) + (old (or (get symbol 'saved-value) (get symbol 'standard-value)))) + ;; Mark default value as set iff different from old value. + (if (or (null old) + (not (equal value (condition-case nil + (eval (car old)) + (error nil))))) + (put symbol 'customized-value (list (custom-quote value))) + (put symbol 'customized-value nil)) + ;; Changed? + (not (equal customized (get symbol 'customized-value))))) + +;;; Theme Manipulation + (defvar custom-loaded-themes nil "Themes in the order they are loaded.") ＠＠ -595,47 +889,80 ＠＠ (memq theme custom-loaded-themes)) (defun provide-theme (theme) - "Indicate that this file provides THEME." + "Indicate that this file provides THEME. +Add THEME to `custom-loaded-themes' and `provide' whatever +is stored in THEME's property `theme-feature'. + +Usually the theme-feature property contains a symbol created +by `custom-make-theme-feature'." (custom-check-theme theme) (provide (get theme 'theme-feature)) - (push theme custom-loaded-themes)) + (setq custom-loaded-themes (nconc (list theme) custom-loaded-themes))) + +(defun require-theme (theme) + "Try to load a theme by requiring its feature. +THEME's feature is stored in THEME's `theme-feature' property. -(defun require-theme (theme &optional soft) - "Try to load a theme by requiring its feature." +Usually the `theme-feature' property contains a symbol created +by `custom-make-theme-feature'." ;; Note we do no check for validity of the theme here. ;; This allows to pull in themes by a file-name convention - (require (get theme 'theme-feature (custom-make-theme-feature theme)))) + (require (or (get theme 'theme-feature) + (custom-make-theme-feature theme)))) +(defun custom-remove-theme (spec-alist theme) + "Delete all elements from SPEC-ALIST whose car is THEME." + (let ((elt (assoc theme spec-alist))) + (while elt + (setq spec-alist (delete elt spec-alist) + elt (assoc theme spec-alist)))) + spec-alist) + (defun custom-do-theme-reset (theme) - ; #### untested! slow! + "Undo all settings defined by THEME. + +A variable remains unchanged if its property `theme-value' does not +contain a value for THEME. A face remains unchanged if its property +`theme-face' does not contain a value for THEME. In either case, all +settings for THEME are removed from the property and the variable or +face is set to the `user' theme. + +See `custom-known-themes' for a list of known themes." (let (spec-list) (mapatoms (lambda (symbol) + ;; This works even if symbol is both a variable and a + ;; face. (setq spec-list (get symbol 'theme-value)) (when spec-list - (setq spec-list (delete-if (lambda (elt) - (eq (car elt) theme)) - spec-list)) - (put symbol 'theme-value spec-list) + (put symbol 'theme-value (custom-remove-theme spec-list theme)) (custom-theme-reset-internal symbol 'user)) (setq spec-list (get symbol 'theme-face)) (when spec-list - (setq spec-list (delete-if (lambda (elt) - (eq (car elt) theme)) - spec-list)) - (put symbol 'theme-face spec-list) + (put symbol 'theme-face (custom-remove-theme spec-list theme)) (custom-theme-reset-internal-face symbol 'user)))))) (defun custom-theme-load-themes (by-theme &rest body) - "Load the themes specified by BODY and record them as required by -theme BY-THEME. BODY is a sequence of - - a SYMBOL - require the theme SYMBOL - - a list (reset THEME) - Undo all the settings made by THEME. - - a list (hidden THEME) - require the THEME but hide it from the user." + "Load the themes specified by BODY. +Record them as required by theme BY-THEME. BODY is a sequence of either + +THEME + BY-THEME requires THEME +\(reset THEME) + Undo all the settings made by THEME +\(hidden THEME) + Require THEME but hide it from the user + +All the themes loaded for BY-THEME are recorded in BY-THEME's property +`theme-loads-themes'. Any theme loaded with the hidden predicate will +be given the property `theme-hidden' unless it has been loaded before. +Whether a theme has been loaded before is determined by the function +`custom-theme-loaded-p'." (custom-check-theme by-theme) - (dolist (theme body) + (let ((theme) + (themes-loaded (get by-theme 'theme-loads-themes))) + (while theme + (setq theme (car body) + body (cdr body)) (cond ((and (consp theme) (eq (car theme) 'reset)) (custom-do-theme-reset (cadr theme))) ((and (consp theme) (eq (car theme) 'hidden)) ＠＠ -644,54 +971,56 ＠＠ (put (cadr theme) 'theme-hidden t))) (t (require-theme theme) - (remprop theme 'theme-hidden))) - (push theme (get by-theme 'theme-loads-themes)))) + (put theme 'theme-hidden nil))) + (setq themes-loaded (nconc (list theme) themes-loaded))) + (put by-theme 'theme-loads-themes themes-loaded))) (defun custom-load-themes (&rest body) "Load themes for the USER theme as specified by BODY. -BODY is as with custom-theme-load-themes." - (apply #'custom-theme-load-themes 'user body)) +See `custom-theme-load-themes' for more information on BODY." + (apply 'custom-theme-load-themes 'user body)) +; (defsubst copy-upto-last (elt list) +; "Copy all the elements of the list upto the last occurrence of elt" +; ;; Is it faster to do more work in C than to do less in elisp? +; (nreverse (cdr (member elt (reverse list))))) +(defun custom-theme-value (theme theme-spec-list) + "Determine the value for THEME defined by THEME-SPEC-LIST. +Returns a list with the original value if found; nil otherwise. +THEME-SPEC-LIST is an alist with themes as its key. As new themes are +installed, these are added to the front of THEME-SPEC-LIST. +Each element has the form -(defsubst copy-upto-last (elt list) - "Copy all the elements of the list upto the last occurrence of elt." - ;; Is it faster to do more work in C than to do less in elisp? - (nreverse (cdr (member elt (reverse list))))) + \(THEME MODE VALUE) -(defun custom-theme-value (theme theme-spec-list) - "Determine the value for THEME defined by THEME-SPEC-LIST. -Returns (list value) if found. Nil otherwise." +MODE is either the symbol `set' or the symbol `reset'. See +`custom-push-theme' for more information on the format of +THEME-SPEC-LIST." ;; Note we do _NOT_ signal an error if the theme is unknown ;; it might have gone away without the user knowing. - (let ((theme-or-lower (memq theme (cons 'user custom-loaded-themes))) - value) - (mapc #'(lambda (theme-spec) - (when (member (car theme-spec) theme-or-lower) - (setq value (cdr theme-spec)) - ;; We need to continue because if theme =A and we found - ;; B then if the load order is B A C B - ;; we actually want the value in C. - (setq theme-or-lower (copy-upto-last (car theme-spec) - theme-or-lower)) - ;; We could should circuit if this is now nil. - )) - theme-spec-list) + (let ((value (cdr (assoc theme theme-spec-list)))) (if value (if (eq (car value) 'set) - (list (cadr value)) - ;; Yet another reset spec. car value = reset + (cdr value) (custom-theme-value (cadr value) theme-spec-list))))) - (defun custom-theme-variable-value (variable theme) - "Return (list value) value of VARIABLE in THEME if the THEME modifies the -VARIABLE. Nil otherwise." + "Return (list value) indicating value of VARIABLE in THEME. +If THEME does not define a value for VARIABLE, return nil. The value +definitions per theme are stored in VARIABLE's property `theme-value'. +The actual work is done by function `custom-theme-value', which see. +See `custom-push-theme' for more information on how these definitions +are stored." (custom-theme-value theme (get variable 'theme-value))) (defun custom-theme-reset-internal (symbol to-theme) + "Reset SYMBOL to the value defined by TO-THEME. +If SYMBOL is not defined in TO-THEME, reset SYMBOL to the standard +value. See `custom-theme-variable-value'. The standard value is +stored in SYMBOL's property `standard-value'." (let ((value (custom-theme-variable-value symbol to-theme)) was-in-theme) (setq was-in-theme value) ＠＠ -699,46 +1028,37 ＠＠ (when value (put symbol 'saved-value was-in-theme) (if (or (get 'force-value symbol) (default-boundp symbol)) - (funcall (get symbol 'custom-set 'set-default) symbol + (funcall (or (get symbol 'custom-set) 'set-default) symbol (eval (car value))))) value)) - (defun custom-theme-reset-variables (theme &rest args) "Reset the value of the variables to values previously defined. Associate this setting with THEME. ARGS is a list of lists of the form - (variable to-theme) + (VARIABLE TO-THEME) -This means reset variable to its value in to-theme." +This means reset VARIABLE to its value in TO-THEME." (custom-check-theme theme) - (mapc #'(lambda (arg) - (apply #'custom-theme-reset-internal arg) + (mapcar '(lambda (arg) + (apply 'custom-theme-reset-internal arg) (custom-push-theme 'theme-value (car arg) theme 'reset (cadr arg))) args)) (defun custom-reset-variables (&rest args) - "Reset the value of the variables to values previously defined. -Associate this setting with the `user' theme. + "Reset the value of the variables to values previously saved. +This is the setting associated the `user' theme. -The ARGS are as in `custom-theme-reset-variables'." - (apply #'custom-theme-reset-variables 'user args)) +ARGS is a list of lists of the form -(defun custom-set-default (variable value) - "Default :set function for a customizable variable. -Normally, this sets the default value of VARIABLE to VALUE, -but if `custom-local-buffer' is non-nil, -this sets the local binding in that buffer instead." - (if custom-local-buffer - (with-current-buffer custom-local-buffer - (set variable value)) - (set-default variable value))) + (VARIABLE TO-THEME) -;;; The End. +This means reset VARIABLE to its value in TO-THEME." + (apply 'custom-theme-reset-variables 'user args)) -;; BEGIN SYNC WITH FSF 21.2 +;;; The End. ;; Process the defcustoms for variables loaded before this file. ;; `custom-declare-variable-list' is defvar'd in subr.el. Utility programs ＠＠ -747,7 +1067,5 ＠＠ (while custom-declare-variable-list (apply 'custom-declare-variable (car custom-declare-variable-list)) (setq custom-declare-variable-list (cdr custom-declare-variable-list))) - -;; END SYNC WITH FSF 21.2 ;; custom.el ends here

1 participants
0 comments

CVS update: MODIFIED: xemacs ... 20 years, 2 months

CVS Monitor

User: viteno Date: 05/02/02 23:51:40 Modified: xemacs version.sh Log: Update xemacs_extra_name. Revision Changes Path 1.1054 +1 -1 XEmacs/xemacs/version.sh (In the diff below, changes in quantity of whitespace are not shown.) Index: version.sh =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/version.sh,v retrieving revision 1.1053 retrieving revision 1.1054 diff -u -b -r1.1053 -r1.1054 --- version.sh 2005/02/01 22:51:18 1.1053 +++ version.sh 2005/02/02 22:51:40 1.1054 ＠＠ -8,4 +8,4 ＠＠ infodock_major_version=4 infodock_minor_version=0 infodock_build_version=8 -xemacs_extra_name="(+CVS-20050201)" +xemacs_extra_name="(+CVS-20050202)"

1 participants
0 comments

2025

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

xemacs-cvs February 2005