X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=src%2Fsymbols.c;h=58cf76f9a6c6a0b6debd91aae7bafd77287ab4cb;hp=01a6c36b7ecf98a12da07296c6c6b81d0ebf7982;hb=79d2db7d65205bc85d471590726d0cf3af5598e0;hpb=a71e0987b7080176e0046b0b0ed72a9a70e2571d diff --git a/src/symbols.c b/src/symbols.c index 01a6c36..58cf76f 100644 --- a/src/symbols.c +++ b/src/symbols.c @@ -1,6 +1,6 @@ /* "intern" and friends -- moved here from lread.c and data.c Copyright (C) 1985-1989, 1992-1994 Free Software Foundation, Inc. - Copyright (C) 1995 Ben Wing. + Copyright (C) 1995, 2000 Ben Wing. This file is part of XEmacs. @@ -58,14 +58,12 @@ Boston, MA 02111-1307, USA. */ #include "console.h" #include "elhash.h" -#include - Lisp_Object Qad_advice_info, Qad_activate; Lisp_Object Qget_value, Qset_value, Qbound_predicate, Qmake_unbound; Lisp_Object Qlocal_predicate, Qmake_local; -Lisp_Object Qboundp, Qfboundp, Qglobally_boundp, Qmakunbound; +Lisp_Object Qboundp, Qglobally_boundp, Qmakunbound; Lisp_Object Qsymbol_value, Qset, Qdefault_boundp, Qdefault_value; Lisp_Object Qset_default, Qsetq_default; Lisp_Object Qmake_variable_buffer_local, Qmake_local_variable; @@ -89,20 +87,20 @@ static Lisp_Object follow_varalias_pointers (Lisp_Object symbol, static Lisp_Object -mark_symbol (Lisp_Object obj, void (*markobj) (Lisp_Object)) +mark_symbol (Lisp_Object obj) { - struct Lisp_Symbol *sym = XSYMBOL (obj); + Lisp_Symbol *sym = XSYMBOL (obj); Lisp_Object pname; - markobj (sym->value); - markobj (sym->function); + mark_object (sym->value); + mark_object (sym->function); XSETSTRING (pname, sym->name); - markobj (pname); + mark_object (pname); if (!symbol_next (sym)) return sym->plist; else { - markobj (sym->plist); + mark_object (sym->plist); /* Mark the rest of the symbols in the obarray hash-chain */ sym = symbol_next (sym); XSETSYMBOL (obj, sym); @@ -111,12 +109,44 @@ mark_symbol (Lisp_Object obj, void (*markobj) (Lisp_Object)) } static const struct lrecord_description symbol_description[] = { - { XD_LISP_OBJECT, offsetof(struct Lisp_Symbol, next), 5 } + { XD_LISP_OBJECT, offsetof (Lisp_Symbol, next) }, + { XD_LISP_OBJECT, offsetof (Lisp_Symbol, name) }, + { XD_LISP_OBJECT, offsetof (Lisp_Symbol, value) }, + { XD_LISP_OBJECT, offsetof (Lisp_Symbol, function) }, + { XD_LISP_OBJECT, offsetof (Lisp_Symbol, plist) }, + { XD_END } }; -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("symbol", symbol, - mark_symbol, print_symbol, 0, 0, 0, - symbol_description, struct Lisp_Symbol); +/* Symbol plists are directly accessible, so we need to protect against + invalid property list structure */ + +static Lisp_Object +symbol_getprop (Lisp_Object symbol, Lisp_Object property) +{ + return external_plist_get (&XSYMBOL (symbol)->plist, property, 0, ERROR_ME); +} + +static int +symbol_putprop (Lisp_Object symbol, Lisp_Object property, Lisp_Object value) +{ + external_plist_put (&XSYMBOL (symbol)->plist, property, value, 0, ERROR_ME); + return 1; +} + +static int +symbol_remprop (Lisp_Object symbol, Lisp_Object property) +{ + return external_remprop (&XSYMBOL (symbol)->plist, property, 0, ERROR_ME); +} + +DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("symbol", symbol, + mark_symbol, print_symbol, + 0, 0, 0, symbol_description, + symbol_getprop, + symbol_putprop, + symbol_remprop, + Fsymbol_plist, + Lisp_Symbol); /**********************************************************************/ @@ -147,10 +177,10 @@ check_obarray (Lisp_Object obarray) } Lisp_Object -intern (CONST char *str) +intern (const char *str) { Bytecount len = strlen (str); - CONST Bufbyte *buf = (CONST Bufbyte *) str; + const Bufbyte *buf = (const Bufbyte *) str; Lisp_Object obarray = Vobarray; if (!VECTORP (obarray) || XVECTOR_LENGTH (obarray) == 0) @@ -168,13 +198,13 @@ intern (CONST char *str) DEFUN ("intern", Fintern, 1, 2, 0, /* Return the canonical symbol whose name is STRING. If there is none, one is created by this function and returned. -A second optional argument specifies the obarray to use; -it defaults to the value of `obarray'. +Optional second argument OBARRAY specifies the obarray to use; +it defaults to the value of the variable `obarray'. */ (string, obarray)) { Lisp_Object object, *ptr; - struct Lisp_Symbol *symbol; + Lisp_Symbol *symbol; Bytecount len; if (NILP (obarray)) obarray = Vobarray; @@ -215,15 +245,15 @@ DEFUN ("intern-soft", Fintern_soft, 1, 2, 0, /* Return the canonical symbol named NAME, or nil if none exists. NAME may be a string or a symbol. If it is a symbol, that exact symbol is searched for. -A second optional argument specifies the obarray to use; -it defaults to the value of `obarray'. +Optional second argument OBARRAY specifies the obarray to use; +it defaults to the value of the variable `obarray'. */ (name, obarray)) { /* #### Bug! (intern-soft "nil") returns nil. Perhaps we should add a DEFAULT-IF-NOT-FOUND arg, like in get. */ Lisp_Object tem; - struct Lisp_String *string; + Lisp_String *string; if (NILP (obarray)) obarray = Vobarray; obarray = check_obarray (obarray); @@ -248,12 +278,12 @@ Delete the symbol named NAME, if any, from OBARRAY. The value is t if a symbol was found and deleted, nil otherwise. NAME may be a string or a symbol. If it is a symbol, that symbol is deleted, if it belongs to OBARRAY--no other symbol is deleted. -OBARRAY defaults to the value of the variable `obarray' +OBARRAY defaults to the value of the variable `obarray'. */ (name, obarray)) { Lisp_Object tem; - struct Lisp_String *string; + Lisp_String *string; int hash; if (NILP (obarray)) obarray = Vobarray; @@ -309,10 +339,10 @@ OBARRAY defaults to the value of the variable `obarray' Also store the bucket number in oblookup_last_bucket_number. */ Lisp_Object -oblookup (Lisp_Object obarray, CONST Bufbyte *ptr, Bytecount size) +oblookup (Lisp_Object obarray, const Bufbyte *ptr, Bytecount size) { int hash, obsize; - struct Lisp_Symbol *tail; + Lisp_Symbol *tail; Lisp_Object bucket; if (!VECTORP (obarray) || @@ -346,10 +376,10 @@ oblookup (Lisp_Object obarray, CONST Bufbyte *ptr, Bytecount size) #if 0 /* Emacs 19.34 */ int -hash_string (CONST Bufbyte *ptr, Bytecount len) +hash_string (const Bufbyte *ptr, Bytecount len) { - CONST Bufbyte *p = ptr; - CONST Bufbyte *end = p + len; + const Bufbyte *p = ptr; + const Bufbyte *end = p + len; Bufbyte c; int hash = 0; @@ -365,7 +395,7 @@ hash_string (CONST Bufbyte *ptr, Bytecount len) /* derived from hashpjw, Dragon Book P436. */ int -hash_string (CONST Bufbyte *ptr, Bytecount len) +hash_string (const Bufbyte *ptr, Bytecount len) { int hash = 0; @@ -395,7 +425,7 @@ map_obarray (Lisp_Object obarray, if (SYMBOLP (tail)) while (1) { - struct Lisp_Symbol *next; + Lisp_Symbol *next; if ((*fn) (tail, arg)) return; next = symbol_next (XSYMBOL (tail)); @@ -419,11 +449,15 @@ OBARRAY defaults to the value of `obarray'. */ (function, obarray)) { + struct gcpro gcpro1; + if (NILP (obarray)) obarray = Vobarray; obarray = check_obarray (obarray); + GCPRO1 (obarray); map_obarray (obarray, mapatoms_1, &function); + UNGCPRO; return Qnil; } @@ -456,23 +490,24 @@ apropos_mapper (Lisp_Object symbol, void *arg) } DEFUN ("apropos-internal", Fapropos_internal, 1, 2, 0, /* -Show all symbols whose names contain match for REGEXP. -If optional 2nd arg PREDICATE is non-nil, (funcall PREDICATE SYMBOL) - is done for each symbol and a symbol is mentioned only if that - returns non-nil. -Return list of symbols found. +Return a list of all symbols whose names contain match for REGEXP. +If optional 2nd arg PREDICATE is non-nil, only symbols for which +\(funcall PREDICATE SYMBOL) returns non-nil are returned. */ (regexp, predicate)) { struct appropos_mapper_closure closure; + struct gcpro gcpro1; CHECK_STRING (regexp); closure.regexp = regexp; closure.predicate = predicate; closure.accumulation = Qnil; + GCPRO1 (closure.accumulation); map_obarray (Vobarray, apropos_mapper, &closure); closure.accumulation = Fsort (closure.accumulation, Qstring_lessp); + UNGCPRO; return closure.accumulation; } @@ -755,10 +790,15 @@ Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. the symbol-value-forward. (See below.) SYMVAL_FIXNUM_FORWARD: + (declare with DEFVAR_INT) + Similar to SYMVAL_OBJECT_FORWARD except that the C variable + is of type "Fixnum", a typedef for "EMACS_INT", and the corresponding + lisp variable is always the corresponding integer. + SYMVAL_BOOLEAN_FORWARD: - (declare with DEFVAR_INT or DEFVAR_BOOL) + (declare with DEFVAR_BOOL) Similar to SYMVAL_OBJECT_FORWARD except that the C variable - is of type "int" and is an integer or boolean, respectively. + is of type "int" and is a boolean. SYMVAL_CONST_OBJECT_FORWARD: SYMVAL_CONST_FIXNUM_FORWARD: @@ -771,8 +811,8 @@ Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. SYMVAL_CONST_SPECIFIER_FORWARD: (declare with DEFVAR_SPECIFIER) - Exactly like SYMVAL_CONST_OBJECT_FORWARD except that error message - you get when attempting to set the value says to use + Exactly like SYMVAL_CONST_OBJECT_FORWARD except that the error + message you get when attempting to set the value says to use `set-specifier' instead. SYMVAL_CURRENT_BUFFER_FORWARD: @@ -897,8 +937,7 @@ Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. symbol to operate on. */ static Lisp_Object -mark_symbol_value_buffer_local (Lisp_Object obj, - void (*markobj) (Lisp_Object)) +mark_symbol_value_buffer_local (Lisp_Object obj) { struct symbol_value_buffer_local *bfwd; @@ -908,15 +947,14 @@ mark_symbol_value_buffer_local (Lisp_Object obj, #endif bfwd = XSYMBOL_VALUE_BUFFER_LOCAL (obj); - markobj (bfwd->default_value); - markobj (bfwd->current_value); - markobj (bfwd->current_buffer); + mark_object (bfwd->default_value); + mark_object (bfwd->current_value); + mark_object (bfwd->current_buffer); return bfwd->current_alist_element; } static Lisp_Object -mark_symbol_value_lisp_magic (Lisp_Object obj, - void (*markobj) (Lisp_Object)) +mark_symbol_value_lisp_magic (Lisp_Object obj) { struct symbol_value_lisp_magic *bfwd; int i; @@ -926,22 +964,21 @@ mark_symbol_value_lisp_magic (Lisp_Object obj, bfwd = XSYMBOL_VALUE_LISP_MAGIC (obj); for (i = 0; i < MAGIC_HANDLER_MAX; i++) { - markobj (bfwd->handler[i]); - markobj (bfwd->harg[i]); + mark_object (bfwd->handler[i]); + mark_object (bfwd->harg[i]); } return bfwd->shadowed; } static Lisp_Object -mark_symbol_value_varalias (Lisp_Object obj, - void (*markobj) (Lisp_Object)) +mark_symbol_value_varalias (Lisp_Object obj) { struct symbol_value_varalias *bfwd; assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_VARALIAS); bfwd = XSYMBOL_VALUE_VARALIAS (obj); - markobj (bfwd->shadowed); + mark_object (bfwd->shadowed); return bfwd->aliasee; } @@ -958,25 +995,34 @@ print_symbol_value_magic (Lisp_Object obj, write_c_string (buf, printcharfun); } +static const struct lrecord_description symbol_value_forward_description[] = { + { XD_END } +}; + static const struct lrecord_description symbol_value_buffer_local_description[] = { - { XD_LISP_OBJECT, offsetof(struct symbol_value_buffer_local, default_value), 4 }, + { XD_LISP_OBJECT, offsetof (struct symbol_value_buffer_local, default_value) }, + { XD_LISP_OBJECT, offsetof (struct symbol_value_buffer_local, current_value) }, + { XD_LISP_OBJECT, offsetof (struct symbol_value_buffer_local, current_buffer) }, + { XD_LISP_OBJECT, offsetof (struct symbol_value_buffer_local, current_alist_element) }, { XD_END } }; static const struct lrecord_description symbol_value_lisp_magic_description[] = { - { XD_LISP_OBJECT, offsetof(struct symbol_value_lisp_magic, handler), 2*MAGIC_HANDLER_MAX+1 }, + { XD_LISP_OBJECT_ARRAY, offsetof (struct symbol_value_lisp_magic, handler), 2*MAGIC_HANDLER_MAX+1 }, { XD_END } }; static const struct lrecord_description symbol_value_varalias_description[] = { - { XD_LISP_OBJECT, offsetof(struct symbol_value_varalias, aliasee), 2 }, + { XD_LISP_OBJECT, offsetof (struct symbol_value_varalias, aliasee) }, + { XD_LISP_OBJECT, offsetof (struct symbol_value_varalias, shadowed) }, { XD_END } }; DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-forward", symbol_value_forward, - this_one_is_unmarkable, - print_symbol_value_magic, 0, 0, 0, 0, + 0, + print_symbol_value_magic, 0, 0, 0, + symbol_value_forward_description, struct symbol_value_forward); DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-buffer-local", @@ -1022,7 +1068,7 @@ static Lisp_Object do_symval_forwarding (Lisp_Object valcontents, struct buffer *buffer, struct console *console) { - CONST struct symbol_value_forward *fwd; + const struct symbol_value_forward *fwd; if (!SYMBOL_VALUE_MAGIC_P (valcontents)) return valcontents; @@ -1032,7 +1078,7 @@ do_symval_forwarding (Lisp_Object valcontents, struct buffer *buffer, { case SYMVAL_FIXNUM_FORWARD: case SYMVAL_CONST_FIXNUM_FORWARD: - return make_int (*((int *)symbol_value_forward_forward (fwd))); + return make_int (*((Fixnum *)symbol_value_forward_forward (fwd))); case SYMVAL_BOOLEAN_FORWARD: case SYMVAL_CONST_BOOLEAN_FORWARD: @@ -1090,7 +1136,7 @@ set_default_buffer_slot_variable (Lisp_Object sym, or symbol-value-buffer-local, and if there's a handler, we should have already called it. */ Lisp_Object valcontents = fetch_value_maybe_past_magic (sym, Qt); - CONST struct symbol_value_forward *fwd + const struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (valcontents); int offset = ((char *) symbol_value_forward_forward (fwd) - (char *) &buffer_local_flags); @@ -1103,8 +1149,6 @@ set_default_buffer_slot_variable (Lisp_Object sym, if (mask > 0) /* Not always per-buffer */ { - Lisp_Object elt; - /* Set value in each buffer which hasn't shadowed the default */ LIST_LOOP_2 (elt, Vbuffer_alist) { @@ -1132,7 +1176,7 @@ set_default_console_slot_variable (Lisp_Object sym, or symbol-value-buffer-local, and if there's a handler, we should have already called it. */ Lisp_Object valcontents = fetch_value_maybe_past_magic (sym, Qt); - CONST struct symbol_value_forward *fwd + const struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (valcontents); int offset = ((char *) symbol_value_forward_forward (fwd) - (char *) &console_local_flags); @@ -1145,8 +1189,6 @@ set_default_console_slot_variable (Lisp_Object sym, if (mask > 0) /* Not always per-console */ { - Lisp_Object console; - /* Set value in each console which hasn't shadowed the default */ LIST_LOOP_2 (console, Vconsole_list) { @@ -1198,7 +1240,7 @@ store_symval_forwarding (Lisp_Object sym, Lisp_Object ovalue, } else { - CONST struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (ovalue); + const struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (ovalue); int (*magicfun) (Lisp_Object simm, Lisp_Object *val, Lisp_Object in_object, int flags) = symbol_value_forward_magicfun (fwd); @@ -1209,14 +1251,14 @@ store_symval_forwarding (Lisp_Object sym, Lisp_Object ovalue, CHECK_INT (newval); if (magicfun) magicfun (sym, &newval, Qnil, 0); - *((int *) symbol_value_forward_forward (fwd)) = XINT (newval); + *((Fixnum *) symbol_value_forward_forward (fwd)) = XINT (newval); return; case SYMVAL_BOOLEAN_FORWARD: if (magicfun) magicfun (sym, &newval, Qnil, 0); *((int *) symbol_value_forward_forward (fwd)) - = ((NILP (newval)) ? 0 : 1); + = !NILP (newval); return; case SYMVAL_OBJECT_FORWARD: @@ -1360,6 +1402,71 @@ set_up_buffer_local_cache (Lisp_Object sym, store_symval_forwarding (sym, bfwd->current_value, new_val); } + +/* SYM is a buffer-local variable, and BFWD is its buffer-local structure. + Flush the cache. BFWD->CURRENT_BUFFER will be nil after this operation. +*/ + +static void +flush_buffer_local_cache (Lisp_Object sym, + struct symbol_value_buffer_local *bfwd) +{ + if (NILP (bfwd->current_buffer)) + /* Cache is already flushed. */ + return; + + /* Flush out the old cache. */ + write_out_buffer_local_cache (sym, bfwd); + + bfwd->current_alist_element = Qnil; + bfwd->current_buffer = Qnil; + + /* Now store default the value into the current-value slot. + We don't simply write it there, because the current-value + slot might be a forwarding pointer, in which case we need + to instead write the value into the C variable. + + We might also want to call a magic function. + + So instead, we call this function. */ + store_symval_forwarding (sym, bfwd->current_value, bfwd->default_value); +} + +/* Flush all the buffer-local variable caches. Whoever has a + non-interned buffer-local variable will be spanked. Whoever has a + magic variable that interns or uninterns symbols... I don't even + want to think about it. +*/ + +void +flush_all_buffer_local_cache (void) +{ + Lisp_Object *syms = XVECTOR_DATA (Vobarray); + long count = XVECTOR_LENGTH (Vobarray); + long i; + + for (i=0; ishadowed = Qunbound; + } else - retval = maybe_call_magic_handler (symbol, Qset, 1, newval); - if (!UNBOUNDP (retval)) - return newval; - valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed; - /* semi-change-o */ - goto retry_2; + { + maybe_call_magic_handler (symbol, Qset, 1, newval); + return XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed = newval; + } } case SYMVAL_VARALIAS: @@ -1677,7 +1785,7 @@ Set SYMBOL's value to NEWVAL, and return NEWVAL. case SYMVAL_CURRENT_BUFFER_FORWARD: { - CONST struct symbol_value_forward *fwd + const struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (valcontents); int mask = XINT (*((Lisp_Object *) symbol_value_forward_forward (fwd))); @@ -1689,7 +1797,7 @@ Set SYMBOL's value to NEWVAL, and return NEWVAL. case SYMVAL_SELECTED_CONSOLE_FORWARD: { - CONST struct symbol_value_forward *fwd + const struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (valcontents); int mask = XINT (*((Lisp_Object *) symbol_value_forward_forward (fwd))); @@ -1827,7 +1935,7 @@ default_value (Lisp_Object sym) case SYMVAL_CURRENT_BUFFER_FORWARD: { - CONST struct symbol_value_forward *fwd + const struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (valcontents); return (*((Lisp_Object *)((char *) XBUFFER (Vbuffer_defaults) + ((char *)symbol_value_forward_forward (fwd) @@ -1836,7 +1944,7 @@ default_value (Lisp_Object sym) case SYMVAL_SELECTED_CONSOLE_FORWARD: { - CONST struct symbol_value_forward *fwd + const struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (valcontents); return (*((Lisp_Object *)((char *) XCONSOLE (Vconsole_defaults) + ((char *)symbol_value_forward_forward (fwd) @@ -1893,7 +2001,7 @@ local bindings in certain buffers. } DEFUN ("set-default", Fset_default, 2, 2, 0, /* -Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated. +Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated. The default value is seen in buffers that do not have their own values for this variable. */ @@ -2060,6 +2168,7 @@ sets it. = alloc_lcrecord_type (struct symbol_value_buffer_local, &lrecord_symbol_value_buffer_local); Lisp_Object foo; + zero_lcrecord (&bfwd->magic); bfwd->magic.type = SYMVAL_BUFFER_LOCAL; bfwd->default_value = find_symbol_value (variable); @@ -2167,6 +2276,7 @@ Use `make-local-hook' instead. /* Make sure variable is set up to hold per-buffer values */ bfwd = alloc_lcrecord_type (struct symbol_value_buffer_local, &lrecord_symbol_value_buffer_local); + zero_lcrecord (&bfwd->magic); bfwd->magic.type = SYMVAL_SOME_BUFFER_LOCAL; bfwd->current_buffer = Qnil; @@ -2276,7 +2386,7 @@ From now on the default value will apply in this buffer. case SYMVAL_CURRENT_BUFFER_FORWARD: { - CONST struct symbol_value_forward *fwd + const struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (valcontents); int offset = ((char *) symbol_value_forward_forward (fwd) - (char *) &buffer_local_flags); @@ -2370,7 +2480,7 @@ From now on the default value will apply in this console. case SYMVAL_SELECTED_CONSOLE_FORWARD: { - CONST struct symbol_value_forward *fwd + const struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (valcontents); int offset = ((char *) symbol_value_forward_forward (fwd) - (char *) &console_local_flags); @@ -2429,7 +2539,7 @@ symbol_value_buffer_local_info (Lisp_Object symbol, struct buffer *buffer) case SYMVAL_CURRENT_BUFFER_FORWARD: { - CONST struct symbol_value_forward *fwd + const struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (valcontents); int mask = XINT (*((Lisp_Object *) symbol_value_forward_forward (fwd))); @@ -2559,7 +2669,7 @@ The returned info will be a symbol, one of DEFUN ("local-variable-p", Flocal_variable_p, 2, 3, 0, /* Return t if SYMBOL's value is local to BUFFER. -If optional third arg AFTER-SET is true, return t if SYMBOL would be +If optional third arg AFTER-SET is non-nil, return t if SYMBOL would be buffer-local after it is set, regardless of whether it is so presently. A nil value for BUFFER is *not* the same as (current-buffer), but means "no buffer". Specifically: @@ -2839,7 +2949,7 @@ maybe_call_magic_handler (Lisp_Object sym, Lisp_Object funsym, int nargs, ...) Lisp_Object legerdemain; struct symbol_value_lisp_magic *bfwd; - assert (nargs >= 0 && nargs < 20); + assert (nargs >= 0 && nargs < countof (args)); legerdemain = XSYMBOL (sym)->value; assert (SYMBOL_VALUE_LISP_MAGIC_P (legerdemain)); bfwd = XSYMBOL_VALUE_LISP_MAGIC (legerdemain); @@ -2887,6 +2997,7 @@ pity, thereby invalidating your code. { bfwd = alloc_lcrecord_type (struct symbol_value_lisp_magic, &lrecord_symbol_value_lisp_magic); + zero_lcrecord (&bfwd->magic); bfwd->magic.type = SYMVAL_LISP_MAGIC; for (i = 0; i < MAGIC_HANDLER_MAX; i++) { @@ -3023,6 +3134,7 @@ has a buffer-local value in any buffer, or the symbols nil or t. bfwd = alloc_lcrecord_type (struct symbol_value_varalias, &lrecord_symbol_value_varalias); + zero_lcrecord (&bfwd->magic); bfwd->magic.type = SYMVAL_VARALIAS; bfwd->aliasee = alias; bfwd->shadowed = valcontents; @@ -3080,6 +3192,31 @@ variable chain of symbols. return follow_varalias_pointers (object, follow_past_lisp_magic); } +DEFUN ("variable-binding-locus", Fvariable_binding_locus, 1, 1, 0, /* +Return a value indicating where VARIABLE's current binding comes from. +If the current binding is buffer-local, the value is the current buffer. +If the current binding is global (the default), the value is nil. +*/ + (variable)) +{ + Lisp_Object valcontents; + + CHECK_SYMBOL (variable); + variable = Findirect_variable (variable, Qnil); + + /* Make sure the current binding is actually swapped in. */ + find_symbol_value (variable); + + valcontents = XSYMBOL (variable)->value; + + if (SYMBOL_VALUE_MAGIC_P (valcontents) + && ((XSYMBOL_VALUE_MAGIC_TYPE (valcontents) == SYMVAL_BUFFER_LOCAL) + || (XSYMBOL_VALUE_MAGIC_TYPE (valcontents) == SYMVAL_SOME_BUFFER_LOCAL)) + && (!NILP (Flocal_variable_p (variable, Fcurrent_buffer (), Qnil)))) + return Fcurrent_buffer (); + else + return Qnil; +} /************************************************************************/ /* initialization */ @@ -3098,26 +3235,37 @@ Lisp_Object Qnull_pointer; #endif /* some losing systems can't have static vars at function scope... */ -static struct symbol_value_magic guts_of_unbound_marker = - { { symbol_value_forward_lheader_initializer, 0, 69}, - SYMVAL_UNBOUND_MARKER }; +static const struct symbol_value_magic guts_of_unbound_marker = +{ /* struct symbol_value_magic */ + { /* struct lcrecord_header */ + { /* struct lrecord_header */ + lrecord_type_symbol_value_forward, /* lrecord_type_index */ + 1, /* mark bit */ + 1, /* c_readonly bit */ + 1, /* lisp_readonly bit */ + }, + 0, /* next */ + 0, /* uid */ + 0, /* free */ + }, + 0, /* value */ + SYMVAL_UNBOUND_MARKER +}; void init_symbols_once_early (void) { -#ifndef Qzero - Qzero = make_int (0); /* Only used if Lisp_Object is a union type */ -#endif + INIT_LRECORD_IMPLEMENTATION (symbol); + INIT_LRECORD_IMPLEMENTATION (symbol_value_forward); + INIT_LRECORD_IMPLEMENTATION (symbol_value_buffer_local); + INIT_LRECORD_IMPLEMENTATION (symbol_value_lisp_magic); + INIT_LRECORD_IMPLEMENTATION (symbol_value_varalias); -#ifndef Qnull_pointer - /* C guarantees that Qnull_pointer will be initialized to all 0 bits, - so the following is actually a no-op. */ - XSETOBJ (Qnull_pointer, (enum Lisp_Type) 0, 0); -#endif + reinit_symbols_once_early (); /* Bootstrapping problem: Qnil isn't set when make_string_nocopy is called the first time. */ - Qnil = Fmake_symbol (make_string_nocopy ((CONST Bufbyte *) "nil", 3)); + Qnil = Fmake_symbol (make_string_nocopy ((const Bufbyte *) "nil", 3)); XSYMBOL (Qnil)->name->plist = Qnil; XSYMBOL (Qnil)->value = Qnil; /* Nihil ex nihil */ XSYMBOL (Qnil)->plist = Qnil; @@ -3134,45 +3282,128 @@ init_symbols_once_early (void) { /* Required to get around a GCC syntax error on certain architectures */ - struct symbol_value_magic *tem = &guts_of_unbound_marker; + const struct symbol_value_magic *tem = &guts_of_unbound_marker; XSETSYMBOL_VALUE_MAGIC (Qunbound, tem); } - if ((CONST void *) XPNTR (Qunbound) != - (CONST void *)&guts_of_unbound_marker) - { - /* This might happen on DATA_SEG_BITS machines. */ - /* abort (); */ - /* Can't represent a pointer to constant C data using a Lisp_Object. - So heap-allocate it. */ - struct symbol_value_magic *urk = xnew (struct symbol_value_magic); - memcpy (urk, &guts_of_unbound_marker, sizeof (*urk)); - XSETSYMBOL_VALUE_MAGIC (Qunbound, urk); - } XSYMBOL (Qnil)->function = Qunbound; defsymbol (&Qt, "t"); - XSYMBOL (Qt)->value = Qt; /* Veritas aetera */ + XSYMBOL (Qt)->value = Qt; /* Veritas aeterna */ Vquit_flag = Qnil; + + dump_add_root_object (&Qnil); + dump_add_root_object (&Qunbound); + dump_add_root_object (&Vquit_flag); +} + +void +reinit_symbols_once_early (void) +{ +#ifndef Qzero + Qzero = make_int (0); /* Only used if Lisp_Object is a union type */ +#endif + +#ifndef Qnull_pointer + /* C guarantees that Qnull_pointer will be initialized to all 0 bits, + so the following is actually a no-op. */ + XSETOBJ (Qnull_pointer, 0); +#endif +} + +static void +defsymbol_massage_name_1 (Lisp_Object *location, const char *name, int dump_p, + int multiword_predicate_p) +{ + char temp[500]; + size_t len = strlen (name) - 1; + size_t i; + + if (multiword_predicate_p) + assert (len + 1 < sizeof (temp)); + else + assert (len < sizeof (temp)); + strcpy (temp, name + 1); /* Remove initial Q */ + if (multiword_predicate_p) + { + strcpy (temp + len - 1, "_p"); + len++; + } + for (i = 0; i < len; i++) + if (temp[i] == '_') + temp[i] = '-'; + *location = Fintern (make_string ((const Bufbyte *) temp, len), Qnil); + if (dump_p) + staticpro (location); + else + staticpro_nodump (location); +} + +void +defsymbol_massage_name_nodump (Lisp_Object *location, const char *name) +{ + defsymbol_massage_name_1 (location, name, 0, 0); +} + +void +defsymbol_massage_name (Lisp_Object *location, const char *name) +{ + defsymbol_massage_name_1 (location, name, 1, 0); } void -defsymbol (Lisp_Object *location, CONST char *name) +defsymbol_massage_multiword_predicate_nodump (Lisp_Object *location, + const char *name) { - *location = Fintern (make_string_nocopy ((CONST Bufbyte *) name, + defsymbol_massage_name_1 (location, name, 0, 1); +} + +void +defsymbol_massage_multiword_predicate (Lisp_Object *location, const char *name) +{ + defsymbol_massage_name_1 (location, name, 1, 1); +} + +void +defsymbol_nodump (Lisp_Object *location, const char *name) +{ + *location = Fintern (make_string_nocopy ((const Bufbyte *) name, + strlen (name)), + Qnil); + staticpro_nodump (location); +} + +void +defsymbol (Lisp_Object *location, const char *name) +{ + *location = Fintern (make_string_nocopy ((const Bufbyte *) name, strlen (name)), Qnil); staticpro (location); } void -defkeyword (Lisp_Object *location, CONST char *name) +defkeyword (Lisp_Object *location, const char *name) { defsymbol (location, name); Fset (*location, *location); } +void +defkeyword_massage_name (Lisp_Object *location, const char *name) +{ + char temp[500]; + size_t len = strlen (name); + + assert (len < sizeof (temp)); + strcpy (temp, name); + temp[1] = ':'; /* it's an underscore in the C variable */ + + defsymbol_massage_name (location, temp); + Fset (*location, *location); +} + #ifdef DEBUG_XEMACS /* Check that nobody spazzed writing a DEFUN. */ static void @@ -3208,27 +3439,26 @@ check_sane_subr (Lisp_Subr *subr, Lisp_Object sym) * Once we have copied everything across, we re-use the original static * structure to store a pointer to the newly allocated one. This will be * used in emodules.c by emodules_doc_subr() to find a pointer to the - * allocated object so that we can set its doc string propperly. + * allocated object so that we can set its doc string properly. * - * NOTE: We dont actually use the DOC pointer here any more, but we did + * NOTE: We don't actually use the DOC pointer here any more, but we did * in an earlier implementation of module support. There is no harm in * setting it here in case we ever need it in future implementations. * subr->doc will point to the new subr structure that was allocated. - * Code can then get this value from the statis subr structure and use + * Code can then get this value from the static subr structure and use * it if required. * - * FIXME: Should newsubr be staticpro()'ed? I dont think so but I need + * FIXME: Should newsubr be staticpro()'ed? I don't think so but I need * a guru to check. */ -#define check_module_subr() \ -do { \ - if (initialized) { \ - struct Lisp_Subr *newsubr; \ - newsubr = (Lisp_Subr *)xmalloc(sizeof(struct Lisp_Subr)); \ - memcpy (newsubr, subr, sizeof(struct Lisp_Subr)); \ - subr->doc = (CONST char *)newsubr; \ - subr = newsubr; \ - } \ +#define check_module_subr() \ +do { \ + if (initialized) { \ + Lisp_Subr *newsubr = (Lisp_Subr *) xmalloc (sizeof (Lisp_Subr)); \ + memcpy (newsubr, subr, sizeof (Lisp_Subr)); \ + subr->doc = (const char *)newsubr; \ + subr = newsubr; \ + } \ } while (0) #else /* ! HAVE_SHLIB */ #define check_module_subr() @@ -3261,65 +3491,98 @@ defsubr_macro (Lisp_Subr *subr) XSYMBOL (sym)->function = Fcons (Qmacro, fun); } -void -deferror (Lisp_Object *symbol, CONST char *name, CONST char *messuhhj, - Lisp_Object inherits_from) +static void +deferror_1 (Lisp_Object *symbol, const char *name, const char *messuhhj, + Lisp_Object inherits_from, int massage_p) { Lisp_Object conds; - defsymbol (symbol, name); + if (massage_p) + defsymbol_massage_name (symbol, name); + else + defsymbol (symbol, name); assert (SYMBOLP (inherits_from)); conds = Fget (inherits_from, Qerror_conditions, Qnil); - pure_put (*symbol, Qerror_conditions, Fcons (*symbol, conds)); + Fput (*symbol, Qerror_conditions, Fcons (*symbol, conds)); /* NOT build_translated_string (). This function is called at load time and the string needs to get translated at run time. (This happens in the function (display-error) in cmdloop.el.) */ - pure_put (*symbol, Qerror_message, build_string (messuhhj)); + Fput (*symbol, Qerror_message, build_string (messuhhj)); +} + +void +deferror (Lisp_Object *symbol, const char *name, const char *messuhhj, + Lisp_Object inherits_from) +{ + deferror_1 (symbol, name, messuhhj, inherits_from, 0); +} + +void +deferror_massage_name (Lisp_Object *symbol, const char *name, + const char *messuhhj, Lisp_Object inherits_from) +{ + deferror_1 (symbol, name, messuhhj, inherits_from, 1); +} + +void +deferror_massage_name_and_message (Lisp_Object *symbol, const char *name, + Lisp_Object inherits_from) +{ + char temp[500]; + size_t i; + size_t len = strlen (name) - 1; + + assert (len < sizeof (temp)); + strcpy (temp, name + 1); /* Remove initial Q */ + temp[0] = toupper (temp[0]); + for (i = 0; i < len; i++) + if (temp[i] == '_') + temp[i] = ' '; + + deferror_1 (symbol, name, temp, inherits_from, 1); } void syms_of_symbols (void) { - defsymbol (&Qvariable_documentation, "variable-documentation"); - defsymbol (&Qvariable_domain, "variable-domain"); /* I18N3 */ - defsymbol (&Qad_advice_info, "ad-advice-info"); - defsymbol (&Qad_activate, "ad-activate"); - - defsymbol (&Qget_value, "get-value"); - defsymbol (&Qset_value, "set-value"); - defsymbol (&Qbound_predicate, "bound-predicate"); - defsymbol (&Qmake_unbound, "make-unbound"); - defsymbol (&Qlocal_predicate, "local-predicate"); - defsymbol (&Qmake_local, "make-local"); - - defsymbol (&Qboundp, "boundp"); - defsymbol (&Qfboundp, "fboundp"); - defsymbol (&Qglobally_boundp, "globally-boundp"); - defsymbol (&Qmakunbound, "makunbound"); - defsymbol (&Qsymbol_value, "symbol-value"); - defsymbol (&Qset, "set"); - defsymbol (&Qsetq_default, "setq-default"); - defsymbol (&Qdefault_boundp, "default-boundp"); - defsymbol (&Qdefault_value, "default-value"); - defsymbol (&Qset_default, "set-default"); - defsymbol (&Qmake_variable_buffer_local, "make-variable-buffer-local"); - defsymbol (&Qmake_local_variable, "make-local-variable"); - defsymbol (&Qkill_local_variable, "kill-local-variable"); - defsymbol (&Qkill_console_local_variable, "kill-console-local-variable"); - defsymbol (&Qsymbol_value_in_buffer, "symbol-value-in-buffer"); - defsymbol (&Qsymbol_value_in_console, "symbol-value-in-console"); - defsymbol (&Qlocal_variable_p, "local-variable-p"); - - defsymbol (&Qconst_integer, "const-integer"); - defsymbol (&Qconst_boolean, "const-boolean"); - defsymbol (&Qconst_object, "const-object"); - defsymbol (&Qconst_specifier, "const-specifier"); - defsymbol (&Qdefault_buffer, "default-buffer"); - defsymbol (&Qcurrent_buffer, "current-buffer"); - defsymbol (&Qconst_current_buffer, "const-current-buffer"); - defsymbol (&Qdefault_console, "default-console"); - defsymbol (&Qselected_console, "selected-console"); - defsymbol (&Qconst_selected_console, "const-selected-console"); + DEFSYMBOL (Qvariable_documentation); + DEFSYMBOL (Qvariable_domain); /* I18N3 */ + DEFSYMBOL (Qad_advice_info); + DEFSYMBOL (Qad_activate); + + DEFSYMBOL (Qget_value); + DEFSYMBOL (Qset_value); + DEFSYMBOL (Qbound_predicate); + DEFSYMBOL (Qmake_unbound); + DEFSYMBOL (Qlocal_predicate); + DEFSYMBOL (Qmake_local); + + DEFSYMBOL (Qboundp); + DEFSYMBOL (Qglobally_boundp); + DEFSYMBOL (Qmakunbound); + DEFSYMBOL (Qsymbol_value); + DEFSYMBOL (Qset); + DEFSYMBOL (Qsetq_default); + DEFSYMBOL (Qdefault_boundp); + DEFSYMBOL (Qdefault_value); + DEFSYMBOL (Qset_default); + DEFSYMBOL (Qmake_variable_buffer_local); + DEFSYMBOL (Qmake_local_variable); + DEFSYMBOL (Qkill_local_variable); + DEFSYMBOL (Qkill_console_local_variable); + DEFSYMBOL (Qsymbol_value_in_buffer); + DEFSYMBOL (Qsymbol_value_in_console); + DEFSYMBOL (Qlocal_variable_p); + DEFSYMBOL (Qconst_integer); + DEFSYMBOL (Qconst_boolean); + DEFSYMBOL (Qconst_object); + DEFSYMBOL (Qconst_specifier); + DEFSYMBOL (Qdefault_buffer); + DEFSYMBOL (Qcurrent_buffer); + DEFSYMBOL (Qconst_current_buffer); + DEFSYMBOL (Qdefault_console); + DEFSYMBOL (Qselected_console); + DEFSYMBOL (Qconst_selected_console); DEFSUBR (Fintern); DEFSUBR (Fintern_soft); @@ -3356,26 +3619,15 @@ syms_of_symbols (void) DEFSUBR (Fdefvaralias); DEFSUBR (Fvariable_alias); DEFSUBR (Findirect_variable); + DEFSUBR (Fvariable_binding_locus); DEFSUBR (Fdontusethis_set_symbol_value_handler); } /* Create and initialize a Lisp variable whose value is forwarded to C data */ void -defvar_magic (CONST char *symbol_name, CONST struct symbol_value_forward *magic) +defvar_magic (const char *symbol_name, const struct symbol_value_forward *magic) { - Lisp_Object sym, kludge; - - /* Check that `magic' points somewhere we can represent as a Lisp pointer */ - XSETOBJ (kludge, Lisp_Type_Record, magic); - if ((void *)magic != (void*) XPNTR (kludge)) - { - /* This might happen on DATA_SEG_BITS machines. */ - /* abort (); */ - /* Copy it to somewhere which is representable. */ - struct symbol_value_forward *p = xnew (struct symbol_value_forward); - memcpy (p, magic, sizeof *magic); - magic = p; - } + Lisp_Object sym; #if defined(HAVE_SHLIB) /* @@ -3387,10 +3639,10 @@ defvar_magic (CONST char *symbol_name, CONST struct symbol_value_forward *magic) sym = Fintern (build_string (symbol_name), Qnil); else #endif - sym = Fintern (make_string_nocopy ((CONST Bufbyte *) symbol_name, + sym = Fintern (make_string_nocopy ((const Bufbyte *) symbol_name, strlen (symbol_name)), Qnil); - XSETOBJ (XSYMBOL (sym)->value, Lisp_Type_Record, magic); + XSETOBJ (XSYMBOL (sym)->value, magic); } void