Mercurial > hg > xemacs-beta

comparison src/symbols.c @ 380:8626e4521993 r21-2-5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-5
author cvs
date Mon, 13 Aug 2007 11:07:10 +0200
parents cc15677e0335
children aabb7f5b1c81
comparison
equal deleted inserted replaced
379:76b7d63099ad 380:8626e4521993
54 #include <config.h> 54 #include <config.h>
55 #include "lisp.h" 55 #include "lisp.h"
56 56
57 #include "buffer.h" /* for Vbuffer_defaults */ 57 #include "buffer.h" /* for Vbuffer_defaults */
58 #include "console.h" 58 #include "console.h"
59 59 #include "elhash.h"
60 #include "elhash.h" /* for HASHTABLE_NONWEAK and HASHTABLE_EQ */
61 60
62 Lisp_Object Qad_advice_info, Qad_activate; 61 Lisp_Object Qad_advice_info, Qad_activate;
63 62
64 Lisp_Object Qget_value, Qset_value, Qbound_predicate, Qmake_unbound; 63 Lisp_Object Qget_value, Qset_value, Qbound_predicate, Qmake_unbound;
65 Lisp_Object Qlocal_predicate, Qmake_local; 64 Lisp_Object Qlocal_predicate, Qmake_local;
66 65
67 Lisp_Object Qboundp, Qfboundp, Qglobally_boundp, Qmakunbound; 66 Lisp_Object Qboundp, Qfboundp, Qglobally_boundp, Qmakunbound;
68 Lisp_Object Qsymbol_value, Qset, Qdefault_boundp, Qdefault_value; 67 Lisp_Object Qsymbol_value, Qset, Qdefault_boundp, Qdefault_value;
69 Lisp_Object Qset_default, Qmake_variable_buffer_local, Qmake_local_variable; 68 Lisp_Object Qset_default, Qsetq_default;
69 Lisp_Object Qmake_variable_buffer_local, Qmake_local_variable;
70 Lisp_Object Qkill_local_variable, Qkill_console_local_variable; 70 Lisp_Object Qkill_local_variable, Qkill_console_local_variable;
71 Lisp_Object Qsymbol_value_in_buffer, Qsymbol_value_in_console; 71 Lisp_Object Qsymbol_value_in_buffer, Qsymbol_value_in_console;
72 Lisp_Object Qlocal_variable_p; 72 Lisp_Object Qlocal_variable_p;
73 73
74 Lisp_Object Qconst_integer, Qconst_boolean, Qconst_object; 74 Lisp_Object Qconst_integer, Qconst_boolean, Qconst_object;
78 78
79 static Lisp_Object maybe_call_magic_handler (Lisp_Object sym, 79 static Lisp_Object maybe_call_magic_handler (Lisp_Object sym,
80 Lisp_Object funsym, 80 Lisp_Object funsym,
81 int nargs, ...); 81 int nargs, ...);
82 static Lisp_Object fetch_value_maybe_past_magic (Lisp_Object sym, 82 static Lisp_Object fetch_value_maybe_past_magic (Lisp_Object sym,
83 Lisp_Object 83 Lisp_Object follow_past_lisp_magic);
84 follow_past_lisp_magic);
85 static Lisp_Object *value_slot_past_magic (Lisp_Object sym); 84 static Lisp_Object *value_slot_past_magic (Lisp_Object sym);
86 static Lisp_Object follow_varalias_pointers (Lisp_Object object, 85 static Lisp_Object follow_varalias_pointers (Lisp_Object symbol,
87 Lisp_Object 86 Lisp_Object follow_past_lisp_magic);
88 follow_past_lisp_magic);
89 87
90 88
91 #ifdef LRECORD_SYMBOL 89 #ifdef LRECORD_SYMBOL
92 90
93 static Lisp_Object 91 static Lisp_Object
94 mark_symbol (Lisp_Object obj, void (*markobj) (Lisp_Object)) 92 mark_symbol (Lisp_Object obj, void (*markobj) (Lisp_Object))
95 { 93 {
96 struct Lisp_Symbol *sym = XSYMBOL (obj); 94 struct Lisp_Symbol *sym = XSYMBOL (obj);
97 Lisp_Object pname; 95 Lisp_Object pname;
98 96
99 ((markobj) (sym->value)); 97 markobj (sym->value);
100 ((markobj) (sym->function)); 98 markobj (sym->function);
101 /* No need to mark through ->obarray, because it only holds nil or t. */ 99 /* No need to mark through ->obarray, because it only holds nil or t. */
102 /*((markobj) (sym->obarray));*/ 100 /* markobj (sym->obarray);*/
103 XSETSTRING (pname, sym->name); 101 XSETSTRING (pname, sym->name);
104 ((markobj) (pname)); 102 markobj (pname);
105 if (!symbol_next (sym)) 103 if (!symbol_next (sym))
106 return sym->plist; 104 return sym->plist;
107 else 105 else
108 { 106 {
109 ((markobj) (sym->plist)); 107 markobj (sym->plist);
110 /* Mark the rest of the symbols in the obarray hash-chain */ 108 /* Mark the rest of the symbols in the obarray hash-chain */
111 sym = symbol_next (sym); 109 sym = symbol_next (sym);
112 XSETSYMBOL (obj, sym); 110 XSETSYMBOL (obj, sym);
113 return obj; 111 return obj;
114 } 112 }
148 } 146 }
149 147
150 Lisp_Object 148 Lisp_Object
151 intern (CONST char *str) 149 intern (CONST char *str)
152 { 150 {
153 Lisp_Object tem;
154 Bytecount len = strlen (str); 151 Bytecount len = strlen (str);
152 CONST Bufbyte *buf = (CONST Bufbyte *) str;
155 Lisp_Object obarray = Vobarray; 153 Lisp_Object obarray = Vobarray;
154
156 if (!VECTORP (obarray) || XVECTOR_LENGTH (obarray) == 0) 155 if (!VECTORP (obarray) || XVECTOR_LENGTH (obarray) == 0)
157 obarray = check_obarray (obarray); 156 obarray = check_obarray (obarray);
158 tem = oblookup (obarray, (CONST Bufbyte *) str, len); 157
159 158 {
160 if (SYMBOLP (tem)) 159 Lisp_Object tem = oblookup (obarray, buf, len);
161 return tem; 160 if (SYMBOLP (tem))
162 return Fintern (((purify_flag) 161 return tem;
163 ? make_pure_pname ((CONST Bufbyte *) str, len, 0) 162 }
164 : make_string ((CONST Bufbyte *) str, len)), 163
164 return Fintern ((purify_flag
165 ? make_pure_pname (buf, len, 0)
166 : make_string (buf, len)),
165 obarray); 167 obarray);
166 } 168 }
167 169
168 DEFUN ("intern", Fintern, 1, 2, 0, /* 170 DEFUN ("intern", Fintern, 1, 2, 0, /*
169 Return the canonical symbol whose name is STRING. 171 Return the canonical symbol whose name is STRING.
170 If there is none, one is created by this function and returned. 172 If there is none, one is created by this function and returned.
171 A second optional argument specifies the obarray to use; 173 A second optional argument specifies the obarray to use;
172 it defaults to the value of `obarray'. 174 it defaults to the value of `obarray'.
173 */ 175 */
174 (str, obarray)) 176 (string, obarray))
175 { 177 {
176 Lisp_Object sym, *ptr; 178 Lisp_Object sym, *ptr;
177 Bytecount len; 179 Bytecount len;
178 180
179 if (NILP (obarray)) obarray = Vobarray; 181 if (NILP (obarray)) obarray = Vobarray;
180 obarray = check_obarray (obarray); 182 obarray = check_obarray (obarray);
181 183
182 CHECK_STRING (str); 184 CHECK_STRING (string);
183 185
184 len = XSTRING_LENGTH (str); 186 len = XSTRING_LENGTH (string);
185 sym = oblookup (obarray, XSTRING_DATA (str), len); 187 sym = oblookup (obarray, XSTRING_DATA (string), len);
186 if (!INTP (sym)) 188 if (!INTP (sym))
187 /* Found it */ 189 /* Found it */
188 return sym; 190 return sym;
189 191
190 ptr = &XVECTOR_DATA (obarray)[XINT (sym)]; 192 ptr = &XVECTOR_DATA (obarray)[XINT (sym)];
191 193
192 if (purify_flag && ! purified (str)) 194 if (purify_flag && ! purified (string))
193 str = make_pure_pname (XSTRING_DATA (str), len, 0); 195 string = make_pure_pname (XSTRING_DATA (string), len, 0);
194 sym = Fmake_symbol (str); 196 sym = Fmake_symbol (string);
195 /* FSFmacs places OBARRAY here, but it is pointless because we do 197 /* FSFmacs places OBARRAY here, but it is pointless because we do
196 not mark through this slot, so it is not usable later (because 198 not mark through this slot, so it is not usable later (because
197 the obarray might have been collected). Marking through the 199 the obarray might have been collected). Marking through the
198 ->obarray slot is an even worse idea, because it would keep 200 ->obarray slot is an even worse idea, because it would keep
199 obarrays from being collected because of symbols pointed to them. 201 obarrays from being collected because of symbols pointed to them.
215 DEFUN ("intern-soft", Fintern_soft, 1, 2, 0, /* 217 DEFUN ("intern-soft", Fintern_soft, 1, 2, 0, /*
216 Return the canonical symbol whose name is STRING, or nil if none exists. 218 Return the canonical symbol whose name is STRING, or nil if none exists.
217 A second optional argument specifies the obarray to use; 219 A second optional argument specifies the obarray to use;
218 it defaults to the value of `obarray'. 220 it defaults to the value of `obarray'.
219 */ 221 */
220 (str, obarray)) 222 (string, obarray))
221 { 223 {
222 Lisp_Object tem; 224 Lisp_Object tem;
223 225
224 if (NILP (obarray)) obarray = Vobarray; 226 if (NILP (obarray)) obarray = Vobarray;
225 obarray = check_obarray (obarray); 227 obarray = check_obarray (obarray);
226 228
227 CHECK_STRING (str); 229 CHECK_STRING (string);
228 230
229 tem = oblookup (obarray, XSTRING_DATA (str), XSTRING_LENGTH (str)); 231 tem = oblookup (obarray, XSTRING_DATA (string), XSTRING_LENGTH (string));
230 if (!INTP (tem)) 232 return !INTP (tem) ? tem : Qnil;
231 return tem;
232 return Qnil;
233 } 233 }
234 234
235 DEFUN ("unintern", Funintern, 1, 2, 0, /* 235 DEFUN ("unintern", Funintern, 1, 2, 0, /*
236 Delete the symbol named NAME, if any, from OBARRAY. 236 Delete the symbol named NAME, if any, from OBARRAY.
237 The value is t if a symbol was found and deleted, nil otherwise. 237 The value is t if a symbol was found and deleted, nil otherwise.
291 return Qt; 291 return Qt;
292 } 292 }
293 293
294 /* Return the symbol in OBARRAY whose names matches the string 294 /* Return the symbol in OBARRAY whose names matches the string
295 of SIZE characters at PTR. If there is no such symbol in OBARRAY, 295 of SIZE characters at PTR. If there is no such symbol in OBARRAY,
296 return nil. 296 return the index into OBARRAY that the string hashes to.
297 297
298 Also store the bucket number in oblookup_last_bucket_number. */ 298 Also store the bucket number in oblookup_last_bucket_number. */
299 299
300 Lisp_Object 300 Lisp_Object
301 oblookup (Lisp_Object obarray, CONST Bufbyte *ptr, Bytecount size) 301 oblookup (Lisp_Object obarray, CONST Bufbyte *ptr, Bytecount size)
313 #if 0 /* FSFmacs */ 313 #if 0 /* FSFmacs */
314 /* #### Huh? */ 314 /* #### Huh? */
315 /* This is sometimes needed in the middle of GC. */ 315 /* This is sometimes needed in the middle of GC. */
316 obsize &= ~ARRAY_MARK_FLAG; 316 obsize &= ~ARRAY_MARK_FLAG;
317 #endif 317 #endif
318 /* Combining next two lines breaks VMS C 2.3. */ 318 hash = hash_string (ptr, size) % obsize;
319 hash = hash_string (ptr, size); 319 oblookup_last_bucket_number = hash;
320 hash %= obsize;
321 bucket = XVECTOR_DATA (obarray)[hash]; 320 bucket = XVECTOR_DATA (obarray)[hash];
322 oblookup_last_bucket_number = hash;
323 if (ZEROP (bucket)) 321 if (ZEROP (bucket))
324 ; 322 ;
325 else if (!SYMBOLP (bucket)) 323 else if (!SYMBOLP (bucket))
326 error ("Bad data in guts of obarray"); /* Like CADR error message */ 324 error ("Bad data in guts of obarray"); /* Like CADR error message */
327 else 325 else
482 int set_it_p); 480 int set_it_p);
483 481
484 DEFUN ("boundp", Fboundp, 1, 1, 0, /* 482 DEFUN ("boundp", Fboundp, 1, 1, 0, /*
485 Return t if SYMBOL's value is not void. 483 Return t if SYMBOL's value is not void.
486 */ 484 */
487 (sym)) 485 (symbol))
488 { 486 {
489 CHECK_SYMBOL (sym); 487 CHECK_SYMBOL (symbol);
490 return UNBOUNDP (find_symbol_value (sym)) ? Qnil : Qt; 488 return UNBOUNDP (find_symbol_value (symbol)) ? Qnil : Qt;
491 } 489 }
492 490
493 DEFUN ("globally-boundp", Fglobally_boundp, 1, 1, 0, /* 491 DEFUN ("globally-boundp", Fglobally_boundp, 1, 1, 0, /*
494 Return t if SYMBOL has a global (non-bound) value. 492 Return t if SYMBOL has a global (non-bound) value.
495 This is for the byte-compiler; you really shouldn't be using this. 493 This is for the byte-compiler; you really shouldn't be using this.
496 */ 494 */
497 (sym)) 495 (symbol))
498 { 496 {
499 CHECK_SYMBOL (sym); 497 CHECK_SYMBOL (symbol);
500 return UNBOUNDP (top_level_value (sym)) ? Qnil : Qt; 498 return UNBOUNDP (top_level_value (symbol)) ? Qnil : Qt;
501 } 499 }
502 500
503 DEFUN ("fboundp", Ffboundp, 1, 1, 0, /* 501 DEFUN ("fboundp", Ffboundp, 1, 1, 0, /*
504 Return t if SYMBOL's function definition is not void. 502 Return t if SYMBOL's function definition is not void.
505 */ 503 */
506 (sym)) 504 (symbol))
507 { 505 {
508 CHECK_SYMBOL (sym); 506 CHECK_SYMBOL (symbol);
509 return UNBOUNDP (XSYMBOL (sym)->function) ? Qnil : Qt; 507 return UNBOUNDP (XSYMBOL (symbol)->function) ? Qnil : Qt;
510 } 508 }
511 509
512 /* Return non-zero if SYM's value or function (the current contents of 510 /* Return non-zero if SYM's value or function (the current contents of
513 which should be passed in as VAL) is constant, i.e. unsettable. */ 511 which should be passed in as VAL) is constant, i.e. unsettable. */
514 512
535 return 1; 533 return 1;
536 default: break; /* Warning suppression */ 534 default: break; /* Warning suppression */
537 } 535 }
538 536
539 /* We don't return true for keywords here because they are handled 537 /* We don't return true for keywords here because they are handled
540 specially by reject_constant_symbols(). */ 538 specially by reject_constant_symbols(). */
541 return 0; 539 return 0;
542 } 540 }
543 541
544 /* We are setting SYM's value slot (or function slot, if FUNCTION_P is 542 /* We are setting SYM's value slot (or function slot, if FUNCTION_P is
545 non-zero) to NEWVAL. Make sure this is allowed. 543 non-zero) to NEWVAL. Make sure this is allowed.
546 FOLLOW_PAST_LISP_MAGIC specifies whether we delve past 544 FOLLOW_PAST_LISP_MAGIC specifies whether we delve past
547 symbol-value-lisp-magic objects. */ 545 symbol-value-lisp-magic objects. */
548 546
549 static void 547 void
550 reject_constant_symbols (Lisp_Object sym, Lisp_Object newval, int function_p, 548 reject_constant_symbols (Lisp_Object sym, Lisp_Object newval, int function_p,
551 Lisp_Object follow_past_lisp_magic) 549 Lisp_Object follow_past_lisp_magic)
552 { 550 {
553 Lisp_Object val = 551 Lisp_Object val =
554 (function_p ? XSYMBOL (sym)->function 552 (function_p ? XSYMBOL (sym)->function
601 } 599 }
602 600
603 DEFUN ("makunbound", Fmakunbound, 1, 1, 0, /* 601 DEFUN ("makunbound", Fmakunbound, 1, 1, 0, /*
604 Make SYMBOL's value be void. 602 Make SYMBOL's value be void.
605 */ 603 */
606 (sym)) 604 (symbol))
607 { 605 {
608 Fset (sym, Qunbound); 606 Fset (symbol, Qunbound);
609 return sym; 607 return symbol;
610 } 608 }
611 609
612 DEFUN ("fmakunbound", Ffmakunbound, 1, 1, 0, /* 610 DEFUN ("fmakunbound", Ffmakunbound, 1, 1, 0, /*
613 Make SYMBOL's function definition be void. 611 Make SYMBOL's function definition be void.
614 */ 612 */
615 (sym)) 613 (symbol))
616 { 614 {
617 CHECK_SYMBOL (sym); 615 CHECK_SYMBOL (symbol);
618 reject_constant_symbols (sym, Qunbound, 1, Qt); 616 reject_constant_symbols (symbol, Qunbound, 1, Qt);
619 XSYMBOL (sym)->function = Qunbound; 617 XSYMBOL (symbol)->function = Qunbound;
620 return sym; 618 return symbol;
621 } 619 }
622 620
623 DEFUN ("symbol-function", Fsymbol_function, 1, 1, 0, /* 621 DEFUN ("symbol-function", Fsymbol_function, 1, 1, 0, /*
624 Return SYMBOL's function definition. Error if that is void. 622 Return SYMBOL's function definition. Error if that is void.
625 */ 623 */
626 (symbol)) 624 (symbol))
627 { 625 {
628 CHECK_SYMBOL (symbol); 626 CHECK_SYMBOL (symbol);
629 if (UNBOUNDP (XSYMBOL (symbol)->function)) 627 if (UNBOUNDP (XSYMBOL (symbol)->function))
630 return Fsignal (Qvoid_function, list1 (symbol)); 628 signal_void_function_error (symbol);
631 return XSYMBOL (symbol)->function; 629 return XSYMBOL (symbol)->function;
632 } 630 }
633 631
634 DEFUN ("symbol-plist", Fsymbol_plist, 1, 1, 0, /* 632 DEFUN ("symbol-plist", Fsymbol_plist, 1, 1, 0, /*
635 Return SYMBOL's property list. 633 Return SYMBOL's property list.
636 */ 634 */
637 (sym)) 635 (symbol))
638 { 636 {
639 CHECK_SYMBOL (sym); 637 CHECK_SYMBOL (symbol);
640 return XSYMBOL (sym)->plist; 638 return XSYMBOL (symbol)->plist;
641 } 639 }
642 640
643 DEFUN ("symbol-name", Fsymbol_name, 1, 1, 0, /* 641 DEFUN ("symbol-name", Fsymbol_name, 1, 1, 0, /*
644 Return SYMBOL's name, a string. 642 Return SYMBOL's name, a string.
645 */ 643 */
646 (sym)) 644 (symbol))
647 { 645 {
648 Lisp_Object name; 646 Lisp_Object name;
649 647
650 CHECK_SYMBOL (sym); 648 CHECK_SYMBOL (symbol);
651 XSETSTRING (name, XSYMBOL (sym)->name); 649 XSETSTRING (name, XSYMBOL (symbol)->name);
652 return name; 650 return name;
653 } 651 }
654 652
655 DEFUN ("fset", Ffset, 2, 2, 0, /* 653 DEFUN ("fset", Ffset, 2, 2, 0, /*
656 Set SYMBOL's function definition to NEWDEF, and return NEWDEF. 654 Set SYMBOL's function definition to NEWDEF, and return NEWDEF.
657 */ 655 */
658 (sym, newdef)) 656 (symbol, newdef))
659 { 657 {
660 /* This function can GC */ 658 /* This function can GC */
661 CHECK_SYMBOL (sym); 659 CHECK_SYMBOL (symbol);
662 reject_constant_symbols (sym, newdef, 1, Qt); 660 reject_constant_symbols (symbol, newdef, 1, Qt);
663 if (!NILP (Vautoload_queue) && !UNBOUNDP (XSYMBOL (sym)->function)) 661 if (!NILP (Vautoload_queue) && !UNBOUNDP (XSYMBOL (symbol)->function))
664 Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function), 662 Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
665 Vautoload_queue); 663 Vautoload_queue);
666 XSYMBOL (sym)->function = newdef; 664 XSYMBOL (symbol)->function = newdef;
667 /* Handle automatic advice activation */ 665 /* Handle automatic advice activation */
668 if (CONSP (XSYMBOL (sym)->plist) && !NILP (Fget (sym, Qad_advice_info, 666 if (CONSP (XSYMBOL (symbol)->plist) &&
669 Qnil))) 667 !NILP (Fget (symbol, Qad_advice_info, Qnil)))
670 { 668 {
671 call2 (Qad_activate, sym, Qnil); 669 call2 (Qad_activate, symbol, Qnil);
672 newdef = XSYMBOL (sym)->function; 670 newdef = XSYMBOL (symbol)->function;
673 } 671 }
674 return newdef; 672 return newdef;
675 } 673 }
676 674
677 /* FSFmacs */ 675 /* FSFmacs */
678 DEFUN ("define-function", Fdefine_function, 2, 2, 0, /* 676 DEFUN ("define-function", Fdefine_function, 2, 2, 0, /*
679 Set SYMBOL's function definition to NEWDEF, and return NEWDEF. 677 Set SYMBOL's function definition to NEWDEF, and return NEWDEF.
680 Associates the function with the current load file, if any. 678 Associates the function with the current load file, if any.
681 */ 679 */
682 (sym, newdef)) 680 (symbol, newdef))
683 { 681 {
684 /* This function can GC */ 682 /* This function can GC */
685 CHECK_SYMBOL (sym); 683 Ffset (symbol, newdef);
686 Ffset (sym, newdef); 684 LOADHIST_ATTACH (symbol);
687 LOADHIST_ATTACH (sym);
688 return newdef; 685 return newdef;
689 } 686 }
690 687
691 688
692 DEFUN ("setplist", Fsetplist, 2, 2, 0, /* 689 DEFUN ("setplist", Fsetplist, 2, 2, 0, /*
693 Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. 690 Set SYMBOL's property list to NEWPLIST, and return NEWPLIST.
694 */ 691 */
695 (sym, newplist)) 692 (symbol, newplist))
696 { 693 {
697 CHECK_SYMBOL (sym); 694 CHECK_SYMBOL (symbol);
698 #if 0 /* Inserted for debugging 6/28/1997 -slb */ 695 #if 0 /* Inserted for debugging 6/28/1997 -slb */
699 /* Somebody is setting a property list of integer 0, who? */ 696 /* Somebody is setting a property list of integer 0, who? */
700 /* Not this way apparently. */ 697 /* Not this way apparently. */
701 if (EQ(newplist, Qzero)) abort(); 698 if (EQ(newplist, Qzero)) abort();
702 #endif 699 #endif
703 700
704 XSYMBOL (sym)->plist = newplist; 701 XSYMBOL (symbol)->plist = newplist;
705 return newplist; 702 return newplist;
706 } 703 }
707 704
708 705
709 /**********************************************************************/ 706 /**********************************************************************/
717 the user level, so there is no loss of generality. 714 the user level, so there is no loss of generality.
718 715
719 If a symbol is "unbound", then the contents of its value cell is 716 If a symbol is "unbound", then the contents of its value cell is
720 Qunbound. Despite appearances, this is *not* a symbol, but is a 717 Qunbound. Despite appearances, this is *not* a symbol, but is a
721 symbol-value-forward object. This is so that printing it results 718 symbol-value-forward object. This is so that printing it results
722 in "INTERNAL EMACS BUG", in case it leaks to Lisp, somehow. 719 in "INTERNAL OBJECT (XEmacs bug?)", in case it leaks to Lisp, somehow.
723 720
724 Logically all of the following objects are "symbol-value-magic" 721 Logically all of the following objects are "symbol-value-magic"
725 objects, and there are some games played w.r.t. this (#### this 722 objects, and there are some games played w.r.t. this (#### this
726 should be cleaned up). SYMBOL_VALUE_MAGIC_P is true for all of 723 should be cleaned up). SYMBOL_VALUE_MAGIC_P is true for all of
727 the object types. XSYMBOL_VALUE_MAGIC_TYPE returns the type of 724 the object types. XSYMBOL_VALUE_MAGIC_TYPE returns the type of
898 mark_symbol_value_buffer_local (Lisp_Object obj, 895 mark_symbol_value_buffer_local (Lisp_Object obj,
899 void (*markobj) (Lisp_Object)) 896 void (*markobj) (Lisp_Object))
900 { 897 {
901 struct symbol_value_buffer_local *bfwd; 898 struct symbol_value_buffer_local *bfwd;
902 899
900 #ifdef ERROR_CHECK_TYPECHECK
903 assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_BUFFER_LOCAL || 901 assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_BUFFER_LOCAL ||
904 XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_SOME_BUFFER_LOCAL); 902 XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_SOME_BUFFER_LOCAL);
903 #endif
905 904
906 bfwd = XSYMBOL_VALUE_BUFFER_LOCAL (obj); 905 bfwd = XSYMBOL_VALUE_BUFFER_LOCAL (obj);
907 ((markobj) (bfwd->default_value)); 906 markobj (bfwd->default_value);
908 ((markobj) (bfwd->current_value)); 907 markobj (bfwd->current_value);
909 ((markobj) (bfwd->current_buffer)); 908 markobj (bfwd->current_buffer);
910 return bfwd->current_alist_element; 909 return bfwd->current_alist_element;
911 } 910 }
912 911
913 static Lisp_Object 912 static Lisp_Object
914 mark_symbol_value_lisp_magic (Lisp_Object obj, 913 mark_symbol_value_lisp_magic (Lisp_Object obj,
920 assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_LISP_MAGIC); 919 assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_LISP_MAGIC);
921 920
922 bfwd = XSYMBOL_VALUE_LISP_MAGIC (obj); 921 bfwd = XSYMBOL_VALUE_LISP_MAGIC (obj);
923 for (i = 0; i < MAGIC_HANDLER_MAX; i++) 922 for (i = 0; i < MAGIC_HANDLER_MAX; i++)
924 { 923 {
925 ((markobj) (bfwd->handler[i])); 924 markobj (bfwd->handler[i]);
926 ((markobj) (bfwd->harg[i])); 925 markobj (bfwd->harg[i]);
927 } 926 }
928 return bfwd->shadowed; 927 return bfwd->shadowed;
929 } 928 }
930 929
931 static Lisp_Object 930 static Lisp_Object
935 struct symbol_value_varalias *bfwd; 934 struct symbol_value_varalias *bfwd;
936 935
937 assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_VARALIAS); 936 assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_VARALIAS);
938 937
939 bfwd = XSYMBOL_VALUE_VARALIAS (obj); 938 bfwd = XSYMBOL_VALUE_VARALIAS (obj);
940 ((markobj) (bfwd->shadowed)); 939 markobj (bfwd->shadowed);
941 return bfwd->aliasee; 940 return bfwd->aliasee;
942 } 941 }
943 942
944 /* Should never, ever be called. (except by an external debugger) */ 943 /* Should never, ever be called. (except by an external debugger) */
945 void 944 void
946 print_symbol_value_magic (Lisp_Object obj, 945 print_symbol_value_magic (Lisp_Object obj,
947 Lisp_Object printcharfun, int escapeflag) 946 Lisp_Object printcharfun, int escapeflag)
948 { 947 {
949 char buf[200]; 948 char buf[200];
950 sprintf (buf, "#<INTERNAL EMACS BUG (%s type %d) 0x%p>", 949 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (%s type %d) 0x%lx>",
951 XRECORD_LHEADER_IMPLEMENTATION (obj)->name, 950 XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
952 XSYMBOL_VALUE_MAGIC_TYPE (obj), 951 XSYMBOL_VALUE_MAGIC_TYPE (obj),
953 (void *) XPNTR (obj)); 952 (long) XPNTR (obj));
954 write_c_string (buf, printcharfun); 953 write_c_string (buf, printcharfun);
955 } 954 }
956 955
957 DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-forward", 956 DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-forward",
958 symbol_value_forward, 957 symbol_value_forward,
1079 *((Lisp_Object *) (offset + (char *) XBUFFER (Vbuffer_defaults))) 1078 *((Lisp_Object *) (offset + (char *) XBUFFER (Vbuffer_defaults)))
1080 = value; 1079 = value;
1081 1080
1082 if (mask > 0) /* Not always per-buffer */ 1081 if (mask > 0) /* Not always per-buffer */
1083 { 1082 {
1084 Lisp_Object tail; 1083 Lisp_Object elt;
1085 1084
1086 /* Set value in each buffer which hasn't shadowed the default */ 1085 /* Set value in each buffer which hasn't shadowed the default */
1087 LIST_LOOP (tail, Vbuffer_alist) 1086 LIST_LOOP_2 (elt, Vbuffer_alist)
1088 { 1087 {
1089 struct buffer *b = XBUFFER (XCDR (XCAR (tail))); 1088 struct buffer *b = XBUFFER (XCDR (elt));
1090 if (!(b->local_var_flags & mask)) 1089 if (!(b->local_var_flags & mask))
1091 { 1090 {
1092 if (magicfun) 1091 if (magicfun)
1093 (magicfun) (sym, &value, make_buffer (b), 0); 1092 magicfun (sym, &value, make_buffer (b), 0);
1094 *((Lisp_Object *) (offset + (char *) b)) = value; 1093 *((Lisp_Object *) (offset + (char *) b)) = value;
1095 } 1094 }
1096 } 1095 }
1097 } 1096 }
1098 } 1097 }
1121 *((Lisp_Object *) (offset + (char *) XCONSOLE (Vconsole_defaults))) 1120 *((Lisp_Object *) (offset + (char *) XCONSOLE (Vconsole_defaults)))
1122 = value; 1121 = value;
1123 1122
1124 if (mask > 0) /* Not always per-console */ 1123 if (mask > 0) /* Not always per-console */
1125 { 1124 {
1126 Lisp_Object tail; 1125 Lisp_Object console;
1127 1126
1128 /* Set value in each console which hasn't shadowed the default */ 1127 /* Set value in each console which hasn't shadowed the default */
1129 LIST_LOOP (tail, Vconsole_list) 1128 LIST_LOOP_2 (console, Vconsole_list)
1130 { 1129 {
1131 Lisp_Object dev = XCAR (tail); 1130 struct console *d = XCONSOLE (console);
1132 struct console *d = XCONSOLE (dev);
1133 if (!(d->local_var_flags & mask)) 1131 if (!(d->local_var_flags & mask))
1134 { 1132 {
1135 if (magicfun) 1133 if (magicfun)
1136 (magicfun) (sym, &value, dev, 0); 1134 magicfun (sym, &value, console, 0);
1137 *((Lisp_Object *) (offset + (char *) d)) = value; 1135 *((Lisp_Object *) (offset + (char *) d)) = value;
1138 } 1136 }
1139 } 1137 }
1140 } 1138 }
1141 } 1139 }
1173 1171
1174 assert (UNBOUNDP (*store_pointer) 1172 assert (UNBOUNDP (*store_pointer)
1175 || !SYMBOL_VALUE_MAGIC_P (*store_pointer)); 1173 || !SYMBOL_VALUE_MAGIC_P (*store_pointer));
1176 *store_pointer = newval; 1174 *store_pointer = newval;
1177 } 1175 }
1178
1179 else 1176 else
1180 { 1177 {
1181 CONST struct symbol_value_forward *fwd 1178 CONST struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (ovalue);
1182 = XSYMBOL_VALUE_FORWARD (ovalue);
1183 int type = XSYMBOL_VALUE_MAGIC_TYPE (ovalue);
1184 int (*magicfun) (Lisp_Object simm, Lisp_Object *val, 1179 int (*magicfun) (Lisp_Object simm, Lisp_Object *val,
1185 Lisp_Object in_object, int flags) = 1180 Lisp_Object in_object, int flags)
1186 symbol_value_forward_magicfun (fwd); 1181 = symbol_value_forward_magicfun (fwd);
1187 1182
1188 switch (type) 1183 switch (XSYMBOL_VALUE_MAGIC_TYPE (ovalue))
1189 { 1184 {
1190 case SYMVAL_FIXNUM_FORWARD: 1185 case SYMVAL_FIXNUM_FORWARD:
1191 { 1186 CHECK_INT (newval);
1192 CHECK_INT (newval); 1187 if (magicfun)
1193 if (magicfun) 1188 magicfun (sym, &newval, Qnil, 0);
1194 (magicfun) (sym, &newval, Qnil, 0); 1189 *((int *) symbol_value_forward_forward (fwd)) = XINT (newval);
1195 *((int *) symbol_value_forward_forward (fwd)) = XINT (newval); 1190 return;
1196 return;
1197 }
1198 1191
1199 case SYMVAL_BOOLEAN_FORWARD: 1192 case SYMVAL_BOOLEAN_FORWARD:
1200 { 1193 if (magicfun)
1201 if (magicfun) 1194 magicfun (sym, &newval, Qnil, 0);
1202 (magicfun) (sym, &newval, Qnil, 0); 1195 *((int *) symbol_value_forward_forward (fwd))
1203 *((int *) symbol_value_forward_forward (fwd)) 1196 = ((NILP (newval)) ? 0 : 1);
1204 = ((NILP (newval)) ? 0 : 1); 1197 return;
1205 return;
1206 }
1207 1198
1208 case SYMVAL_OBJECT_FORWARD: 1199 case SYMVAL_OBJECT_FORWARD:
1209 { 1200 if (magicfun)
1210 if (magicfun) 1201 magicfun (sym, &newval, Qnil, 0);
1211 (magicfun) (sym, &newval, Qnil, 0); 1202 *((Lisp_Object *) symbol_value_forward_forward (fwd)) = newval;
1212 *((Lisp_Object *) symbol_value_forward_forward (fwd)) = newval; 1203 return;
1213 return;
1214 }
1215 1204
1216 case SYMVAL_DEFAULT_BUFFER_FORWARD: 1205 case SYMVAL_DEFAULT_BUFFER_FORWARD:
1217 { 1206 set_default_buffer_slot_variable (sym, newval);
1218 set_default_buffer_slot_variable (sym, newval); 1207 return;
1219 return;
1220 }
1221 1208
1222 case SYMVAL_CURRENT_BUFFER_FORWARD: 1209 case SYMVAL_CURRENT_BUFFER_FORWARD:
1223 { 1210 if (magicfun)
1224 if (magicfun) 1211 magicfun (sym, &newval, make_buffer (current_buffer), 0);
1225 (magicfun) (sym, &newval, make_buffer (current_buffer), 0); 1212 *((Lisp_Object *) ((char *) current_buffer
1226 *((Lisp_Object *) ((char *) current_buffer 1213 + ((char *) symbol_value_forward_forward (fwd)
1227 + ((char *) symbol_value_forward_forward (fwd) 1214 - (char *) &buffer_local_flags)))
1228 - (char *) &buffer_local_flags))) 1215 = newval;
1229 = newval; 1216 return;
1230 return;
1231 }
1232 1217
1233 case SYMVAL_DEFAULT_CONSOLE_FORWARD: 1218 case SYMVAL_DEFAULT_CONSOLE_FORWARD:
1234 { 1219 set_default_console_slot_variable (sym, newval);
1235 set_default_console_slot_variable (sym, newval); 1220 return;
1236 return;
1237 }
1238 1221
1239 case SYMVAL_SELECTED_CONSOLE_FORWARD: 1222 case SYMVAL_SELECTED_CONSOLE_FORWARD:
1240 { 1223 if (magicfun)
1241 if (magicfun) 1224 magicfun (sym, &newval, Vselected_console, 0);
1242 (magicfun) (sym, &newval, Vselected_console, 0); 1225 *((Lisp_Object *) ((char *) XCONSOLE (Vselected_console)
1243 *((Lisp_Object *) ((char *) XCONSOLE (Vselected_console) 1226 + ((char *) symbol_value_forward_forward (fwd)
1244 + ((char *) symbol_value_forward_forward (fwd) 1227 - (char *) &console_local_flags)))
1245 - (char *) &console_local_flags))) 1228 = newval;
1246 = newval; 1229 return;
1247 return;
1248 }
1249 1230
1250 default: 1231 default:
1251 abort (); 1232 abort ();
1252 } 1233 }
1253 } 1234 }
1333 write_out_buffer_local_cache (sym, bfwd); 1314 write_out_buffer_local_cache (sym, bfwd);
1334 1315
1335 /* Retrieve the new alist element and new value. */ 1316 /* Retrieve the new alist element and new value. */
1336 if (NILP (new_alist_el) 1317 if (NILP (new_alist_el)
1337 && set_it_p) 1318 && set_it_p)
1338 new_alist_el = buffer_local_alist_element (buf, sym, bfwd); 1319 new_alist_el = buffer_local_alist_element (buf, sym, bfwd);
1339 1320
1340 if (NILP (new_alist_el)) 1321 if (NILP (new_alist_el))
1341 new_val = bfwd->default_value; 1322 new_val = bfwd->default_value;
1342 else 1323 else
1343 new_val = Fcdr (new_alist_el); 1324 new_val = Fcdr (new_alist_el);
1458 buf == XBUFFER (bfwd->current_buffer)) 1439 buf == XBUFFER (bfwd->current_buffer))
1459 valcontents = bfwd->current_value; 1440 valcontents = bfwd->current_value;
1460 else if (NILP (symcons)) 1441 else if (NILP (symcons))
1461 { 1442 {
1462 if (set_it_p) 1443 if (set_it_p)
1463 valcontents = assq_no_quit (sym, buf->local_var_alist); 1444 valcontents = assq_no_quit (sym, buf->local_var_alist);
1464 if (NILP (valcontents)) 1445 if (NILP (valcontents))
1465 valcontents = bfwd->default_value; 1446 valcontents = bfwd->default_value;
1466 else 1447 else
1467 valcontents = XCDR (valcontents); 1448 valcontents = XCDR (valcontents);
1468 } 1449 }
1488 { 1469 {
1489 struct buffer *buf; 1470 struct buffer *buf;
1490 1471
1491 CHECK_SYMBOL (sym); 1472 CHECK_SYMBOL (sym);
1492 1473
1493 if (!NILP (buffer)) 1474 if (NILP (buffer))
1475 buf = current_buffer;
1476 else
1494 { 1477 {
1495 CHECK_BUFFER (buffer); 1478 CHECK_BUFFER (buffer);
1496 buf = XBUFFER (buffer); 1479 buf = XBUFFER (buffer);
1497 } 1480 }
1498 else
1499 buf = current_buffer;
1500 1481
1501 return find_symbol_value_1 (sym, buf, 1482 return find_symbol_value_1 (sym, buf,
1502 /* If it bombs out at startup due to a 1483 /* If it bombs out at startup due to a
1503 Lisp error, this may be nil. */ 1484 Lisp error, this may be nil. */
1504 CONSOLEP (Vselected_console) 1485 CONSOLEP (Vselected_console)
1508 static Lisp_Object 1489 static Lisp_Object
1509 symbol_value_in_console (Lisp_Object sym, Lisp_Object console) 1490 symbol_value_in_console (Lisp_Object sym, Lisp_Object console)
1510 { 1491 {
1511 CHECK_SYMBOL (sym); 1492 CHECK_SYMBOL (sym);
1512 1493
1513 if (!NILP (console)) 1494 if (NILP (console))
1495 console = Vselected_console;
1496 else
1514 CHECK_CONSOLE (console); 1497 CHECK_CONSOLE (console);
1515 else
1516 console = Vselected_console;
1517 1498
1518 return find_symbol_value_1 (sym, current_buffer, XCONSOLE (console), 0, 1499 return find_symbol_value_1 (sym, current_buffer, XCONSOLE (console), 0,
1519 Qnil, 1); 1500 Qnil, 1);
1520 } 1501 }
1521 1502
1527 Lisp_Object 1508 Lisp_Object
1528 find_symbol_value (Lisp_Object sym) 1509 find_symbol_value (Lisp_Object sym)
1529 { 1510 {
1530 /* WARNING: This function can be called when current_buffer is 0 1511 /* WARNING: This function can be called when current_buffer is 0
1531 and Vselected_console is Qnil, early in initialization. */ 1512 and Vselected_console is Qnil, early in initialization. */
1532 struct console *dev; 1513 struct console *con;
1533 Lisp_Object valcontents; 1514 Lisp_Object valcontents;
1534 1515
1535 CHECK_SYMBOL (sym); 1516 CHECK_SYMBOL (sym);
1536 1517
1537 valcontents = XSYMBOL (sym)->value; 1518 valcontents = XSYMBOL (sym)->value;
1538 if (!SYMBOL_VALUE_MAGIC_P (valcontents)) 1519 if (!SYMBOL_VALUE_MAGIC_P (valcontents))
1539 return valcontents; 1520 return valcontents;
1540 1521
1541 if (CONSOLEP (Vselected_console)) 1522 if (CONSOLEP (Vselected_console))
1542 dev = XCONSOLE (Vselected_console); 1523 con = XCONSOLE (Vselected_console);
1543 else 1524 else
1544 { 1525 {
1545 /* This can also get called while we're preparing to shutdown. 1526 /* This can also get called while we're preparing to shutdown.
1546 #### What should really happen in that case? Should we 1527 #### What should really happen in that case? Should we
1547 actually fix things so we can't get here in that case? */ 1528 actually fix things so we can't get here in that case? */
1548 assert (!initialized || preparing_for_armageddon); 1529 assert (!initialized || preparing_for_armageddon);
1549 dev = 0; 1530 con = 0;
1550 } 1531 }
1551 1532
1552 return find_symbol_value_1 (sym, current_buffer, dev, 1, Qnil, 1); 1533 return find_symbol_value_1 (sym, current_buffer, con, 1, Qnil, 1);
1553 } 1534 }
1554 1535
1555 /* This is an optimized function for quick lookup of buffer local symbols 1536 /* This is an optimized function for quick lookup of buffer local symbols
1556 by avoiding O(n) search. This will work when either: 1537 by avoiding O(n) search. This will work when either:
1557 a) We have already found the symbol e.g. by traversing local_var_alist. 1538 a) We have already found the symbol e.g. by traversing local_var_alist.
1568 Lisp_Object 1549 Lisp_Object
1569 find_symbol_value_quickly (Lisp_Object symbol_cons, int find_it_p) 1550 find_symbol_value_quickly (Lisp_Object symbol_cons, int find_it_p)
1570 { 1551 {
1571 /* WARNING: This function can be called when current_buffer is 0 1552 /* WARNING: This function can be called when current_buffer is 0
1572 and Vselected_console is Qnil, early in initialization. */ 1553 and Vselected_console is Qnil, early in initialization. */
1573 struct console *dev; 1554 struct console *con;
1574 Lisp_Object sym = find_it_p ? XCAR (symbol_cons) : symbol_cons; 1555 Lisp_Object sym = find_it_p ? XCAR (symbol_cons) : symbol_cons;
1575 1556
1576 CHECK_SYMBOL (sym); 1557 CHECK_SYMBOL (sym);
1577 if (CONSOLEP (Vselected_console)) 1558 if (CONSOLEP (Vselected_console))
1578 dev = XCONSOLE (Vselected_console); 1559 con = XCONSOLE (Vselected_console);
1579 else 1560 else
1580 { 1561 {
1581 /* This can also get called while we're preparing to shutdown. 1562 /* This can also get called while we're preparing to shutdown.
1582 #### What should really happen in that case? Should we 1563 #### What should really happen in that case? Should we
1583 actually fix things so we can't get here in that case? */ 1564 actually fix things so we can't get here in that case? */
1584 assert (!initialized || preparing_for_armageddon); 1565 assert (!initialized || preparing_for_armageddon);
1585 dev = 0; 1566 con = 0;
1586 } 1567 }
1587 1568
1588 return find_symbol_value_1 (sym, current_buffer, dev, 1, 1569 return find_symbol_value_1 (sym, current_buffer, con, 1,
1589 find_it_p ? symbol_cons : Qnil, 1570 find_it_p ? symbol_cons : Qnil,
1590 find_it_p); 1571 find_it_p);
1591 } 1572 }
1592 1573
1593 DEFUN ("symbol-value", Fsymbol_value, 1, 1, 0, /* 1574 DEFUN ("symbol-value", Fsymbol_value, 1, 1, 0, /*
1594 Return SYMBOL's value. Error if that is void. 1575 Return SYMBOL's value. Error if that is void.
1595 */ 1576 */
1596 (sym)) 1577 (symbol))
1597 { 1578 {
1598 Lisp_Object val = find_symbol_value (sym); 1579 Lisp_Object val = find_symbol_value (symbol);
1599 1580
1600 if (UNBOUNDP (val)) 1581 if (UNBOUNDP (val))
1601 return Fsignal (Qvoid_variable, list1 (sym)); 1582 return Fsignal (Qvoid_variable, list1 (symbol));
1602 else 1583 else
1603 return val; 1584 return val;
1604 } 1585 }
1605 1586
1606 DEFUN ("set", Fset, 2, 2, 0, /* 1587 DEFUN ("set", Fset, 2, 2, 0, /*
1607 Set SYMBOL's value to NEWVAL, and return NEWVAL. 1588 Set SYMBOL's value to NEWVAL, and return NEWVAL.
1608 */ 1589 */
1609 (sym, newval)) 1590 (symbol, newval))
1610 { 1591 {
1611 REGISTER Lisp_Object valcontents; 1592 REGISTER Lisp_Object valcontents;
1593 struct Lisp_Symbol *sym;
1612 /* remember, we're called by Fmakunbound() as well */ 1594 /* remember, we're called by Fmakunbound() as well */
1613 1595
1614 CHECK_SYMBOL (sym); 1596 CHECK_SYMBOL (symbol);
1615 1597
1616 retry: 1598 retry:
1617 valcontents = XSYMBOL (sym)->value; 1599 sym = XSYMBOL (symbol);
1618 if (NILP (sym) || EQ (sym, Qt) || SYMBOL_VALUE_MAGIC_P (valcontents) 1600 valcontents = sym->value;
1619 || SYMBOL_IS_KEYWORD (sym)) 1601
1620 reject_constant_symbols (sym, newval, 0, 1602 if (EQ (symbol, Qnil) ||
1603 EQ (symbol, Qt) ||
1604 SYMBOL_IS_KEYWORD (symbol))
1605 reject_constant_symbols (symbol, newval, 0,
1621 UNBOUNDP (newval) ? Qmakunbound : Qset); 1606 UNBOUNDP (newval) ? Qmakunbound : Qset);
1622 else 1607
1623 { 1608 if (!SYMBOL_VALUE_MAGIC_P (valcontents) || UNBOUNDP (valcontents))
1624 XSYMBOL (sym)->value = newval; 1609 {
1610 sym->value = newval;
1625 return newval; 1611 return newval;
1626 } 1612 }
1627 1613
1614 reject_constant_symbols (symbol, newval, 0,
1615 UNBOUNDP (newval) ? Qmakunbound : Qset);
1616
1628 retry_2: 1617 retry_2:
1629 1618
1630 if (SYMBOL_VALUE_MAGIC_P (valcontents)) 1619 switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
1631 { 1620 {
1632 switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents)) 1621 case SYMVAL_LISP_MAGIC:
1633 { 1622 {
1634 case SYMVAL_LISP_MAGIC: 1623 Lisp_Object retval;
1624
1625 if (UNBOUNDP (newval))
1626 retval = maybe_call_magic_handler (symbol, Qmakunbound, 0);
1627 else
1628 retval = maybe_call_magic_handler (symbol, Qset, 1, newval);
1629 if (!UNBOUNDP (retval))
1630 return newval;
1631 valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
1632 /* semi-change-o */
1633 goto retry_2;
1634 }
1635
1636 case SYMVAL_VARALIAS:
1637 symbol = follow_varalias_pointers (symbol,
1638 UNBOUNDP (newval)
1639 ? Qmakunbound : Qset);
1640 /* presto change-o! */
1641 goto retry;
1642
1643 case SYMVAL_FIXNUM_FORWARD:
1644 case SYMVAL_BOOLEAN_FORWARD:
1645 case SYMVAL_OBJECT_FORWARD:
1646 case SYMVAL_DEFAULT_BUFFER_FORWARD:
1647 case SYMVAL_DEFAULT_CONSOLE_FORWARD:
1648 if (UNBOUNDP (newval))
1649 signal_error (Qerror,
1650 list2 (build_string ("Cannot makunbound"), symbol));
1651 break;
1652
1653 /* case SYMVAL_UNBOUND_MARKER: break; */
1654
1655 case SYMVAL_CURRENT_BUFFER_FORWARD:
1656 {
1657 CONST struct symbol_value_forward *fwd
1658 = XSYMBOL_VALUE_FORWARD (valcontents);
1659 int mask = XINT (*((Lisp_Object *)
1660 symbol_value_forward_forward (fwd)));
1661 if (mask > 0)
1662 /* Setting this variable makes it buffer-local */
1663 current_buffer->local_var_flags |= mask;
1664 break;
1665 }
1666
1667 case SYMVAL_SELECTED_CONSOLE_FORWARD:
1668 {
1669 CONST struct symbol_value_forward *fwd
1670 = XSYMBOL_VALUE_FORWARD (valcontents);
1671 int mask = XINT (*((Lisp_Object *)
1672 symbol_value_forward_forward (fwd)));
1673 if (mask > 0)
1674 /* Setting this variable makes it console-local */
1675 XCONSOLE (Vselected_console)->local_var_flags |= mask;
1676 break;
1677 }
1678
1679 case SYMVAL_BUFFER_LOCAL:
1680 case SYMVAL_SOME_BUFFER_LOCAL:
1681 {
1682 /* If we want to examine or set the value and
1683 CURRENT-BUFFER is current, we just examine or set
1684 CURRENT-VALUE. If CURRENT-BUFFER is not current, we
1685 store the current CURRENT-VALUE value into
1686 CURRENT-ALIST- ELEMENT, then find the appropriate alist
1687 element for the buffer now current and set up
1688 CURRENT-ALIST-ELEMENT. Then we set CURRENT-VALUE out
1689 of that element, and store into CURRENT-BUFFER.
1690
1691 If we are setting the variable and the current buffer does
1692 not have an alist entry for this variable, an alist entry is
1693 created.
1694
1695 Note that CURRENT-VALUE can be a forwarding pointer.
1696 Each time it is examined or set, forwarding must be
1697 done. */
1698 struct symbol_value_buffer_local *bfwd
1699 = XSYMBOL_VALUE_BUFFER_LOCAL (valcontents);
1700 int some_buffer_local_p =
1701 (bfwd->magic.type == SYMVAL_SOME_BUFFER_LOCAL);
1702 /* What value are we caching right now? */
1703 Lisp_Object aelt = bfwd->current_alist_element;
1704
1705 if (!NILP (bfwd->current_buffer) &&
1706 current_buffer == XBUFFER (bfwd->current_buffer)
1707 && ((some_buffer_local_p)
1708 ? 1 /* doesn't automatically become local */
1709 : !NILP (aelt) /* already local */
1710 ))
1635 { 1711 {
1636 Lisp_Object retval; 1712 /* Cache is valid */
1637 1713 valcontents = bfwd->current_value;
1638 if (UNBOUNDP (newval))
1639 retval = maybe_call_magic_handler (sym, Qmakunbound, 0);
1640 else
1641 retval = maybe_call_magic_handler (sym, Qset, 1, newval);
1642 if (!UNBOUNDP (retval))
1643 return newval;
1644 valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
1645 /* semi-change-o */
1646 goto retry_2;
1647 } 1714 }
1648 1715 else
1649 case SYMVAL_VARALIAS:
1650 sym = follow_varalias_pointers (sym,
1651 UNBOUNDP (newval)
1652 ? Qmakunbound : Qset);
1653 /* presto change-o! */
1654 goto retry;
1655
1656 case SYMVAL_FIXNUM_FORWARD:
1657 case SYMVAL_BOOLEAN_FORWARD:
1658 case SYMVAL_OBJECT_FORWARD:
1659 case SYMVAL_DEFAULT_BUFFER_FORWARD:
1660 case SYMVAL_DEFAULT_CONSOLE_FORWARD:
1661 if (UNBOUNDP (newval))
1662 signal_error (Qerror,
1663 list2 (build_string ("Cannot makunbound"), sym));
1664 break;
1665
1666 case SYMVAL_UNBOUND_MARKER:
1667 break;
1668
1669 case SYMVAL_CURRENT_BUFFER_FORWARD:
1670 { 1716 {
1671 CONST struct symbol_value_forward *fwd 1717 /* If the current buffer is not the buffer whose binding is
1672 = XSYMBOL_VALUE_FORWARD (valcontents); 1718 currently cached, or if it's a SYMVAL_BUFFER_LOCAL and
1673 int mask = XINT (*((Lisp_Object *) 1719 we're looking at the default value, the cache is invalid; we
1674 symbol_value_forward_forward (fwd))); 1720 need to write it out, and find the new CURRENT-ALIST-ELEMENT
1675 if (mask > 0) 1721 */
1676 /* Setting this variable makes it buffer-local */ 1722
1677 current_buffer->local_var_flags |= mask; 1723 /* Write out the cached value for the old buffer; copy it
1678 break; 1724 back to its alist element. This works if the current
1725 buffer only sees the default value, too. */
1726 write_out_buffer_local_cache (symbol, bfwd);
1727
1728 /* Find the new value for CURRENT-ALIST-ELEMENT. */
1729 aelt = buffer_local_alist_element (current_buffer, symbol, bfwd);
1730 if (NILP (aelt))
1731 {
1732 /* This buffer is still seeing the default value. */
1733 if (!some_buffer_local_p)
1734 {
1735 /* If it's a SYMVAL_BUFFER_LOCAL, give this buffer a
1736 new assoc for a local value and set
1737 CURRENT-ALIST-ELEMENT to point to that. */
1738 aelt =
1739 do_symval_forwarding (bfwd->current_value,
1740 current_buffer,
1741 XCONSOLE (Vselected_console));
1742 aelt = Fcons (symbol, aelt);
1743 current_buffer->local_var_alist
1744 = Fcons (aelt, current_buffer->local_var_alist);
1745 }
1746 else
1747 {
1748 /* If the variable is a SYMVAL_SOME_BUFFER_LOCAL,
1749 we're currently seeing the default value. */
1750 ;
1751 }
1752 }
1753 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1754 bfwd->current_alist_element = aelt;
1755 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
1756 XSETBUFFER (bfwd->current_buffer, current_buffer);
1757 valcontents = bfwd->current_value;
1679 } 1758 }
1680 1759 break;
1681 case SYMVAL_SELECTED_CONSOLE_FORWARD: 1760 }
1682 { 1761 default:
1683 CONST struct symbol_value_forward *fwd 1762 abort ();
1684 = XSYMBOL_VALUE_FORWARD (valcontents); 1763 }
1685 int mask = XINT (*((Lisp_Object *) 1764 store_symval_forwarding (symbol, valcontents, newval);
1686 symbol_value_forward_forward (fwd)));
1687 if (mask > 0)
1688 /* Setting this variable makes it console-local */
1689 XCONSOLE (Vselected_console)->local_var_flags |= mask;
1690 break;
1691 }
1692
1693 case SYMVAL_BUFFER_LOCAL:
1694 case SYMVAL_SOME_BUFFER_LOCAL:
1695 {
1696 /* If we want to examine or set the value and
1697 CURRENT-BUFFER is current, we just examine or set
1698 CURRENT-VALUE. If CURRENT-BUFFER is not current, we
1699 store the current CURRENT-VALUE value into
1700 CURRENT-ALIST- ELEMENT, then find the appropriate alist
1701 element for the buffer now current and set up
1702 CURRENT-ALIST-ELEMENT. Then we set CURRENT-VALUE out
1703 of that element, and store into CURRENT-BUFFER.
1704
1705 If we are setting the variable and the current buffer does
1706 not have an alist entry for this variable, an alist entry is
1707 created.
1708
1709 Note that CURRENT-VALUE can be a forwarding pointer.
1710 Each time it is examined or set, forwarding must be
1711 done. */
1712 struct symbol_value_buffer_local *bfwd
1713 = XSYMBOL_VALUE_BUFFER_LOCAL (valcontents);
1714 int some_buffer_local_p =
1715 (bfwd->magic.type == SYMVAL_SOME_BUFFER_LOCAL);
1716 /* What value are we caching right now? */
1717 Lisp_Object aelt = bfwd->current_alist_element;
1718
1719 if (!NILP (bfwd->current_buffer) &&
1720 current_buffer == XBUFFER (bfwd->current_buffer)
1721 && ((some_buffer_local_p)
1722 ? 1 /* doesn't automatically become local */
1723 : !NILP (aelt) /* already local */
1724 ))
1725 {
1726 /* Cache is valid */
1727 valcontents = bfwd->current_value;
1728 }
1729 else
1730 {
1731 /* If the current buffer is not the buffer whose binding is
1732 currently cached, or if it's a SYMVAL_BUFFER_LOCAL and
1733 we're looking at the default value, the cache is invalid; we
1734 need to write it out, and find the new CURRENT-ALIST-ELEMENT
1735 */
1736
1737 /* Write out the cached value for the old buffer; copy it
1738 back to its alist element. This works if the current
1739 buffer only sees the default value, too. */
1740 write_out_buffer_local_cache (sym, bfwd);
1741
1742 /* Find the new value for CURRENT-ALIST-ELEMENT. */
1743 aelt = buffer_local_alist_element (current_buffer, sym, bfwd);
1744 if (NILP (aelt))
1745 {
1746 /* This buffer is still seeing the default value. */
1747 if (!some_buffer_local_p)
1748 {
1749 /* If it's a SYMVAL_BUFFER_LOCAL, give this buffer a
1750 new assoc for a local value and set
1751 CURRENT-ALIST-ELEMENT to point to that. */
1752 aelt =
1753 do_symval_forwarding (bfwd->current_value,
1754 current_buffer,
1755 XCONSOLE (Vselected_console));
1756 aelt = Fcons (sym, aelt);
1757 current_buffer->local_var_alist
1758 = Fcons (aelt, current_buffer->local_var_alist);
1759 }
1760 else
1761 {
1762 /* If the variable is a SYMVAL_SOME_BUFFER_LOCAL,
1763 we're currently seeing the default value. */
1764 ;
1765 }
1766 }
1767 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1768 bfwd->current_alist_element = aelt;
1769 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
1770 XSETBUFFER (bfwd->current_buffer, current_buffer);
1771 valcontents = bfwd->current_value;
1772 }
1773 break;
1774 }
1775 default:
1776 abort ();
1777 }
1778 }
1779 store_symval_forwarding (sym, valcontents, newval);
1780 1765
1781 return newval; 1766 return newval;
1782 } 1767 }
1783 1768
1784 1769
1856 /* For other variables, get the current value. */ 1841 /* For other variables, get the current value. */
1857 return do_symval_forwarding (valcontents, current_buffer, 1842 return do_symval_forwarding (valcontents, current_buffer,
1858 XCONSOLE (Vselected_console)); 1843 XCONSOLE (Vselected_console));
1859 } 1844 }
1860 1845
1861 RETURN_NOT_REACHED(Qnil) /* suppress compiler warning */ 1846 RETURN_NOT_REACHED (Qnil) /* suppress compiler warning */
1862 } 1847 }
1863 1848
1864 DEFUN ("default-boundp", Fdefault_boundp, 1, 1, 0, /* 1849 DEFUN ("default-boundp", Fdefault_boundp, 1, 1, 0, /*
1865 Return t if SYMBOL has a non-void default value. 1850 Return t if SYMBOL has a non-void default value.
1866 This is the value that is seen in buffers that do not have their own values 1851 This is the value that is seen in buffers that do not have their own values
1867 for this variable. 1852 for this variable.
1868 */ 1853 */
1869 (sym)) 1854 (symbol))
1870 { 1855 {
1871 return UNBOUNDP (default_value (sym)) ? Qnil : Qt; 1856 return UNBOUNDP (default_value (symbol)) ? Qnil : Qt;
1872 } 1857 }
1873 1858
1874 DEFUN ("default-value", Fdefault_value, 1, 1, 0, /* 1859 DEFUN ("default-value", Fdefault_value, 1, 1, 0, /*
1875 Return SYMBOL's default value. 1860 Return SYMBOL's default value.
1876 This is the value that is seen in buffers that do not have their own values 1861 This is the value that is seen in buffers that do not have their own values
1877 for this variable. The default value is meaningful for variables with 1862 for this variable. The default value is meaningful for variables with
1878 local bindings in certain buffers. 1863 local bindings in certain buffers.
1879 */ 1864 */
1880 (sym)) 1865 (symbol))
1881 { 1866 {
1882 Lisp_Object value = default_value (sym); 1867 Lisp_Object value = default_value (symbol);
1883 1868
1884 return UNBOUNDP (value) ? Fsignal (Qvoid_variable, list1 (sym)) : value; 1869 return UNBOUNDP (value) ? Fsignal (Qvoid_variable, list1 (symbol)) : value;
1885 } 1870 }
1886 1871
1887 DEFUN ("set-default", Fset_default, 2, 2, 0, /* 1872 DEFUN ("set-default", Fset_default, 2, 2, 0, /*
1888 Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated. 1873 Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.
1889 The default value is seen in buffers that do not have their own values 1874 The default value is seen in buffers that do not have their own values
1890 for this variable. 1875 for this variable.
1891 */ 1876 */
1892 (sym, value)) 1877 (symbol, value))
1893 { 1878 {
1894 Lisp_Object valcontents; 1879 Lisp_Object valcontents;
1895 1880
1896 CHECK_SYMBOL (sym); 1881 CHECK_SYMBOL (symbol);
1897 1882
1898 retry: 1883 retry:
1899 valcontents = XSYMBOL (sym)->value; 1884 valcontents = XSYMBOL (symbol)->value;
1900 1885
1901 retry_2: 1886 retry_2:
1902 if (!SYMBOL_VALUE_MAGIC_P (valcontents)) 1887 if (!SYMBOL_VALUE_MAGIC_P (valcontents))
1903 return Fset (sym, value); 1888 return Fset (symbol, value);
1904 1889
1905 switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents)) 1890 switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
1906 { 1891 {
1907 case SYMVAL_LISP_MAGIC: 1892 case SYMVAL_LISP_MAGIC:
1908 RETURN_IF_NOT_UNBOUND (maybe_call_magic_handler (sym, Qset_default, 1, 1893 RETURN_IF_NOT_UNBOUND (maybe_call_magic_handler (symbol, Qset_default, 1,
1909 value)); 1894 value));
1910 valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed; 1895 valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
1911 /* semi-change-o */ 1896 /* semi-change-o */
1912 goto retry_2; 1897 goto retry_2;
1913 1898
1914 case SYMVAL_VARALIAS: 1899 case SYMVAL_VARALIAS:
1915 sym = follow_varalias_pointers (sym, Qset_default); 1900 symbol = follow_varalias_pointers (symbol, Qset_default);
1916 /* presto change-o! */ 1901 /* presto change-o! */
1917 goto retry; 1902 goto retry;
1918 1903
1919 case SYMVAL_CURRENT_BUFFER_FORWARD: 1904 case SYMVAL_CURRENT_BUFFER_FORWARD:
1920 set_default_buffer_slot_variable (sym, value); 1905 set_default_buffer_slot_variable (symbol, value);
1921 return value; 1906 return value;
1922 1907
1923 case SYMVAL_SELECTED_CONSOLE_FORWARD: 1908 case SYMVAL_SELECTED_CONSOLE_FORWARD:
1924 set_default_console_slot_variable (sym, value); 1909 set_default_console_slot_variable (symbol, value);
1925 return value; 1910 return value;
1926 1911
1927 case SYMVAL_BUFFER_LOCAL: 1912 case SYMVAL_BUFFER_LOCAL:
1928 case SYMVAL_SOME_BUFFER_LOCAL: 1913 case SYMVAL_SOME_BUFFER_LOCAL:
1929 { 1914 {
1933 1918
1934 bfwd->default_value = value; 1919 bfwd->default_value = value;
1935 /* If current-buffer doesn't shadow default_value, 1920 /* If current-buffer doesn't shadow default_value,
1936 * we must set the CURRENT-VALUE slot too */ 1921 * we must set the CURRENT-VALUE slot too */
1937 if (NILP (bfwd->current_alist_element)) 1922 if (NILP (bfwd->current_alist_element))
1938 store_symval_forwarding (sym, bfwd->current_value, value); 1923 store_symval_forwarding (symbol, bfwd->current_value, value);
1939 return value; 1924 return value;
1940 } 1925 }
1941 1926
1942 default: 1927 default:
1943 return Fset (sym, value); 1928 return Fset (symbol, value);
1944 } 1929 }
1945 RETURN_NOT_REACHED(Qnil) /* suppress compiler warning */ 1930 }
1946 } 1931
1947 1932 DEFUN ("setq-default", Fsetq_default, 0, UNEVALLED, 0, /*
1948 DEFUN ("setq-default", Fsetq_default, 2, UNEVALLED, 0, /* 1933 Set the default value of variable SYMBOL to VALUE.
1949 Set the default value of variable SYM to VALUE. 1934 SYMBOL, the variable name, is literal (not evaluated);
1950 SYM, the variable name, is literal (not evaluated);
1951 VALUE is an expression and it is evaluated. 1935 VALUE is an expression and it is evaluated.
1952 The default value of a variable is seen in buffers 1936 The default value of a variable is seen in buffers
1953 that do not have their own values for the variable. 1937 that do not have their own values for the variable.
1954 1938
1955 More generally, you can use multiple variables and values, as in 1939 More generally, you can use multiple variables and values, as in
1956 (setq-default SYM VALUE SYM VALUE...) 1940 (setq-default SYMBOL VALUE SYMBOL VALUE...)
1957 This sets each SYM's default value to the corresponding VALUE. 1941 This sets each SYMBOL's default value to the corresponding VALUE.
1958 The VALUE for the Nth SYM can refer to the new default values 1942 The VALUE for the Nth SYMBOL can refer to the new default values
1959 of previous SYMs. 1943 of previous SYMBOLs.
1960 */ 1944 */
1961 (args)) 1945 (args))
1962 { 1946 {
1963 /* This function can GC */ 1947 /* This function can GC */
1964 Lisp_Object args_left; 1948 Lisp_Object symbol, tail, val = Qnil;
1965 Lisp_Object val, sym; 1949 int nargs;
1966 struct gcpro gcpro1; 1950 struct gcpro gcpro1;
1967 1951
1968 if (NILP (args)) 1952 GET_LIST_LENGTH (args, nargs);
1969 return Qnil; 1953
1970 1954 if (nargs & 1) /* Odd number of arguments? */
1971 args_left = args; 1955 Fsignal (Qwrong_number_of_arguments,
1972 GCPRO1 (args); 1956 list2 (Qsetq_default, make_int (nargs)));
1973 1957
1974 do 1958 GCPRO1 (val);
1975 { 1959
1976 val = Feval (Fcar (Fcdr (args_left))); 1960 PROPERTY_LIST_LOOP (tail, symbol, val, args)
1977 sym = Fcar (args_left); 1961 {
1978 Fset_default (sym, val); 1962 val = Feval (val);
1979 args_left = Fcdr (Fcdr (args_left)); 1963 Fset_default (symbol, val);
1980 } 1964 }
1981 while (!NILP (args_left));
1982 1965
1983 UNGCPRO; 1966 UNGCPRO;
1984 return val; 1967 return val;
1985 } 1968 }
1986 1969
2377 Lisp_Object in_object, int flags) = 2360 Lisp_Object in_object, int flags) =
2378 symbol_value_forward_magicfun (fwd); 2361 symbol_value_forward_magicfun (fwd);
2379 Lisp_Object oldval = * (Lisp_Object *) 2362 Lisp_Object oldval = * (Lisp_Object *)
2380 (offset + (char *) XCONSOLE (Vconsole_defaults)); 2363 (offset + (char *) XCONSOLE (Vconsole_defaults));
2381 if (magicfun) 2364 if (magicfun)
2382 (magicfun) (variable, &oldval, Vselected_console, 0); 2365 magicfun (variable, &oldval, Vselected_console, 0);
2383 *(Lisp_Object *) (offset + (char *) XCONSOLE (Vselected_console)) 2366 *(Lisp_Object *) (offset + (char *) XCONSOLE (Vselected_console))
2384 = oldval; 2367 = oldval;
2385 XCONSOLE (Vselected_console)->local_var_flags &= ~mask; 2368 XCONSOLE (Vselected_console)->local_var_flags &= ~mask;
2386 } 2369 }
2387 return variable; 2370 return variable;
2388 } 2371 }
2389 2372
2390 default: 2373 default:
2391 return variable; 2374 return variable;
2392 } 2375 }
2393 RETURN_NOT_REACHED(Qnil) /* suppress compiler warning */
2394 } 2376 }
2395 2377
2396 /* Used by specbind to determine what effects it might have. Returns: 2378 /* Used by specbind to determine what effects it might have. Returns:
2397 * 0 if symbol isn't buffer-local, and wouldn't be after it is set 2379 * 0 if symbol isn't buffer-local, and wouldn't be after it is set
2398 * <0 if symbol isn't presently buffer-local, but set would make it so 2380 * <0 if symbol isn't presently buffer-local, but set would make it so
2462 { 2444 {
2463 Lisp_Object value; 2445 Lisp_Object value;
2464 CHECK_SYMBOL (symbol); 2446 CHECK_SYMBOL (symbol);
2465 CHECK_BUFFER (buffer); 2447 CHECK_BUFFER (buffer);
2466 value = symbol_value_in_buffer (symbol, buffer); 2448 value = symbol_value_in_buffer (symbol, buffer);
2467 if (UNBOUNDP (value)) 2449 return UNBOUNDP (value) ? unbound_value : value;
2468 return unbound_value;
2469 else
2470 return value;
2471 } 2450 }
2472 2451
2473 DEFUN ("symbol-value-in-console", Fsymbol_value_in_console, 2, 3, 0, /* 2452 DEFUN ("symbol-value-in-console", Fsymbol_value_in_console, 2, 3, 0, /*
2474 Return the value of SYMBOL in CONSOLE, or UNBOUND-VALUE if it is unbound. 2453 Return the value of SYMBOL in CONSOLE, or UNBOUND-VALUE if it is unbound.
2475 */ 2454 */
2477 { 2456 {
2478 Lisp_Object value; 2457 Lisp_Object value;
2479 CHECK_SYMBOL (symbol); 2458 CHECK_SYMBOL (symbol);
2480 CHECK_CONSOLE (console); 2459 CHECK_CONSOLE (console);
2481 value = symbol_value_in_console (symbol, console); 2460 value = symbol_value_in_console (symbol, console);
2482 if (UNBOUNDP (value)) 2461 return UNBOUNDP (value) ? unbound_value : value;
2483 return unbound_value;
2484 else
2485 return value;
2486 } 2462 }
2487 2463
2488 DEFUN ("built-in-variable-type", Fbuilt_in_variable_type, 1, 1, 0, /* 2464 DEFUN ("built-in-variable-type", Fbuilt_in_variable_type, 1, 1, 0, /*
2489 If SYM is a built-in variable, return info about this; else return nil. 2465 If SYMBOL is a built-in variable, return info about this; else return nil.
2490 The returned info will be a symbol, one of 2466 The returned info will be a symbol, one of
2491 2467
2492 `object' A simple built-in variable. 2468 `object' A simple built-in variable.
2493 `const-object' Same, but cannot be set. 2469 `const-object' Same, but cannot be set.
2494 `integer' A built-in integer variable. 2470 `integer' A built-in integer variable.
2503 `selected-console' A built-in console-local variable. 2479 `selected-console' A built-in console-local variable.
2504 `const-selected-console' Same, but cannot be set. 2480 `const-selected-console' Same, but cannot be set.
2505 `default-console' Forwards to the default value of a built-in 2481 `default-console' Forwards to the default value of a built-in
2506 console-local variable. 2482 console-local variable.
2507 */ 2483 */
2508 (sym)) 2484 (symbol))
2509 { 2485 {
2510 REGISTER Lisp_Object valcontents; 2486 REGISTER Lisp_Object valcontents;
2511 2487
2512 CHECK_SYMBOL (sym); 2488 CHECK_SYMBOL (symbol);
2513 2489
2514 retry: 2490 retry:
2515 valcontents = XSYMBOL (sym)->value; 2491 valcontents = XSYMBOL (symbol)->value;
2492
2516 retry_2: 2493 retry_2:
2517 2494 if (!SYMBOL_VALUE_MAGIC_P (valcontents))
2518 if (SYMBOL_VALUE_MAGIC_P (valcontents)) 2495 return Qnil;
2519 { 2496
2520 switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents)) 2497 switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
2521 { 2498 {
2522 case SYMVAL_LISP_MAGIC: 2499 case SYMVAL_LISP_MAGIC:
2523 valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed; 2500 valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
2524 /* semi-change-o */ 2501 /* semi-change-o */
2525 goto retry_2; 2502 goto retry_2;
2526 2503
2527 case SYMVAL_VARALIAS: 2504 case SYMVAL_VARALIAS:
2528 sym = follow_varalias_pointers (sym, Qt); 2505 symbol = follow_varalias_pointers (symbol, Qt);
2529 /* presto change-o! */ 2506 /* presto change-o! */
2530 goto retry; 2507 goto retry;
2531 2508
2532 case SYMVAL_BUFFER_LOCAL: 2509 case SYMVAL_BUFFER_LOCAL:
2533 case SYMVAL_SOME_BUFFER_LOCAL: 2510 case SYMVAL_SOME_BUFFER_LOCAL:
2534 valcontents = 2511 valcontents =
2535 XSYMBOL_VALUE_BUFFER_LOCAL (valcontents)->current_value; 2512 XSYMBOL_VALUE_BUFFER_LOCAL (valcontents)->current_value;
2536 /* semi-change-o */ 2513 /* semi-change-o */
2537 goto retry_2; 2514 goto retry_2;
2538 2515
2539 case SYMVAL_FIXNUM_FORWARD: 2516 case SYMVAL_FIXNUM_FORWARD: return Qinteger;
2540 return Qinteger; 2517 case SYMVAL_CONST_FIXNUM_FORWARD: return Qconst_integer;
2541 2518 case SYMVAL_BOOLEAN_FORWARD: return Qboolean;
2542 case SYMVAL_CONST_FIXNUM_FORWARD: 2519 case SYMVAL_CONST_BOOLEAN_FORWARD: return Qconst_boolean;
2543 return Qconst_integer; 2520 case SYMVAL_OBJECT_FORWARD: return Qobject;
2544 2521 case SYMVAL_CONST_OBJECT_FORWARD: return Qconst_object;
2545 case SYMVAL_BOOLEAN_FORWARD: 2522 case SYMVAL_CONST_SPECIFIER_FORWARD: return Qconst_specifier;
2546 return Qboolean; 2523 case SYMVAL_DEFAULT_BUFFER_FORWARD: return Qdefault_buffer;
2547 2524 case SYMVAL_CURRENT_BUFFER_FORWARD: return Qcurrent_buffer;
2548 case SYMVAL_CONST_BOOLEAN_FORWARD: 2525 case SYMVAL_CONST_CURRENT_BUFFER_FORWARD: return Qconst_current_buffer;
2549 return Qconst_boolean; 2526 case SYMVAL_DEFAULT_CONSOLE_FORWARD: return Qdefault_console;
2550 2527 case SYMVAL_SELECTED_CONSOLE_FORWARD: return Qselected_console;
2551 case SYMVAL_OBJECT_FORWARD: 2528 case SYMVAL_CONST_SELECTED_CONSOLE_FORWARD: return Qconst_selected_console;
2552 return Qobject; 2529 case SYMVAL_UNBOUND_MARKER: return Qnil;
2553 2530
2554 case SYMVAL_CONST_OBJECT_FORWARD: 2531 default:
2555 return Qconst_object; 2532 abort (); return Qnil;
2556 2533 }
2557 case SYMVAL_CONST_SPECIFIER_FORWARD:
2558 return Qconst_specifier;
2559
2560 case SYMVAL_DEFAULT_BUFFER_FORWARD:
2561 return Qdefault_buffer;
2562
2563 case SYMVAL_CURRENT_BUFFER_FORWARD:
2564 return Qcurrent_buffer;
2565
2566 case SYMVAL_CONST_CURRENT_BUFFER_FORWARD:
2567 return Qconst_current_buffer;
2568
2569 case SYMVAL_DEFAULT_CONSOLE_FORWARD:
2570 return Qdefault_console;
2571
2572 case SYMVAL_SELECTED_CONSOLE_FORWARD:
2573 return Qselected_console;
2574
2575 case SYMVAL_CONST_SELECTED_CONSOLE_FORWARD:
2576 return Qconst_selected_console;
2577
2578 case SYMVAL_UNBOUND_MARKER:
2579 return Qnil;
2580
2581 default:
2582 abort ();
2583 }
2584 }
2585
2586 return Qnil;
2587 } 2534 }
2588 2535
2589 2536
2590 DEFUN ("local-variable-p", Flocal_variable_p, 2, 3, 0, /* 2537 DEFUN ("local-variable-p", Flocal_variable_p, 2, 3, 0, /*
2591 Return t if SYMBOL's value is local to BUFFER. 2538 Return t if SYMBOL's value is local to BUFFER.
2634 2581
2635 The interface and/or function name is sure to change before this 2582 The interface and/or function name is sure to change before this
2636 gets into its final form. I currently like the way everything is 2583 gets into its final form. I currently like the way everything is
2637 set up and it has all the features I want it to have, except for 2584 set up and it has all the features I want it to have, except for
2638 one: I really want to be able to have multiple nested handlers, 2585 one: I really want to be able to have multiple nested handlers,
2639 to implement an `advice'-like capabiility. This would allow, 2586 to implement an `advice'-like capability. This would allow,
2640 for example, a clean way of implementing `debug-if-set' or 2587 for example, a clean way of implementing `debug-if-set' or
2641 `debug-if-referenced' and such. 2588 `debug-if-referenced' and such.
2642 2589
2643 NOTE NOTE NOTE NOTE NOTE NOTE NOTE: 2590 NOTE NOTE NOTE NOTE NOTE NOTE NOTE:
2644 ************************************************************ 2591 ************************************************************
2943 } 2890 }
2944 2891
2945 2892
2946 /* functions for working with variable aliases. */ 2893 /* functions for working with variable aliases. */
2947 2894
2948 /* Follow the chain of variable aliases for OBJECT. Return the 2895 /* Follow the chain of variable aliases for SYMBOL. Return the
2949 resulting symbol, whose value cell is guaranteed not to be a 2896 resulting symbol, whose value cell is guaranteed not to be a
2950 symbol-value-varalias. 2897 symbol-value-varalias.
2951 2898
2952 Also maybe follow past symbol-value-lisp-magic -> symbol-value-varalias. 2899 Also maybe follow past symbol-value-lisp-magic -> symbol-value-varalias.
2953 If FUNSYM is t, always follow in such a case. If FUNSYM is nil, 2900 If FUNSYM is t, always follow in such a case. If FUNSYM is nil,
2971 we make any variable that is lisp-magic -> varalias behave as if 2918 we make any variable that is lisp-magic -> varalias behave as if
2972 the lisp-magic is not present at all. 2919 the lisp-magic is not present at all.
2973 */ 2920 */
2974 2921
2975 static Lisp_Object 2922 static Lisp_Object
2976 follow_varalias_pointers (Lisp_Object object, 2923 follow_varalias_pointers (Lisp_Object symbol,
2977 Lisp_Object follow_past_lisp_magic) 2924 Lisp_Object follow_past_lisp_magic)
2978 { 2925 {
2979 Lisp_Object tortoise = object; 2926 #define VARALIAS_INDIRECTION_SUSPICION_LENGTH 16
2980 Lisp_Object hare = object; 2927 Lisp_Object tortoise, hare, val;
2928 int count;
2981 2929
2982 /* quick out just in case */ 2930 /* quick out just in case */
2983 if (!SYMBOL_VALUE_MAGIC_P (XSYMBOL (object)->value)) 2931 if (!SYMBOL_VALUE_MAGIC_P (XSYMBOL (symbol)->value))
2984 return object; 2932 return symbol;
2985 2933
2986 /* based off of indirect_function() */ 2934 /* Compare implementation of indirect_function(). */
2987 for (;;) 2935 for (hare = tortoise = symbol, count = 0;
2988 { 2936 val = fetch_value_maybe_past_magic (hare, follow_past_lisp_magic),
2989 Lisp_Object value; 2937 SYMBOL_VALUE_VARALIAS_P (val);
2990 2938 hare = symbol_value_varalias_aliasee (XSYMBOL_VALUE_VARALIAS (val)),
2991 value = fetch_value_maybe_past_magic (hare, follow_past_lisp_magic); 2939 count++)
2992 if (!SYMBOL_VALUE_VARALIAS_P (value)) 2940 {
2993 break; 2941 if (count < VARALIAS_INDIRECTION_SUSPICION_LENGTH) continue;
2994 hare = symbol_value_varalias_aliasee (XSYMBOL_VALUE_VARALIAS (value)); 2942
2995 value = fetch_value_maybe_past_magic (hare, follow_past_lisp_magic); 2943 if (count & 1)
2996 if (!SYMBOL_VALUE_VARALIAS_P (value)) 2944 tortoise = symbol_value_varalias_aliasee
2997 break; 2945 (XSYMBOL_VALUE_VARALIAS (fetch_value_maybe_past_magic
2998 hare = symbol_value_varalias_aliasee (XSYMBOL_VALUE_VARALIAS (value)); 2946 (tortoise, follow_past_lisp_magic)));
2999
3000 value = fetch_value_maybe_past_magic (tortoise, follow_past_lisp_magic);
3001 tortoise = symbol_value_varalias_aliasee
3002 (XSYMBOL_VALUE_VARALIAS (value));
3003
3004 if (EQ (hare, tortoise)) 2947 if (EQ (hare, tortoise))
3005 return Fsignal (Qcyclic_variable_indirection, list1 (object)); 2948 return Fsignal (Qcyclic_variable_indirection, list1 (symbol));
3006 } 2949 }
3007 2950
3008 return hare; 2951 return hare;
3009 } 2952 }
3010 2953
3145 Qzero = make_int (0); /* Only used if Lisp_Object is a union type */ 3088 Qzero = make_int (0); /* Only used if Lisp_Object is a union type */
3146 #endif 3089 #endif
3147 3090
3148 #ifndef Qnull_pointer 3091 #ifndef Qnull_pointer
3149 /* C guarantees that Qnull_pointer will be initialized to all 0 bits, 3092 /* C guarantees that Qnull_pointer will be initialized to all 0 bits,
3150 so the following is a actually a no-op. */ 3093 so the following is actually a no-op. */
3151 XSETOBJ (Qnull_pointer, (enum Lisp_Type) 0, 0); 3094 XSETOBJ (Qnull_pointer, (enum Lisp_Type) 0, 0);
3152 #endif 3095 #endif
3153 3096
3154 /* see comment in Fpurecopy() */ 3097 /* see comment in Fpurecopy() */
3155 Vpure_uninterned_symbol_table = 3098 Vpure_uninterned_symbol_table =
3156 make_lisp_hashtable (50, HASHTABLE_NONWEAK, HASHTABLE_EQ); 3099 make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
3157 staticpro (&Vpure_uninterned_symbol_table); 3100 staticpro (&Vpure_uninterned_symbol_table);
3158 3101
3159 Qnil = Fmake_symbol (make_pure_pname ((CONST Bufbyte *) "nil", 3, 1)); 3102 Qnil = Fmake_symbol (make_pure_pname ((CONST Bufbyte *) "nil", 3, 1));
3160 /* Bootstrapping problem: Qnil isn't set when make_pure_pname is 3103 /* Bootstrapping problem: Qnil isn't set when make_pure_pname is
3161 called the first time. */ 3104 called the first time. */
3213 { 3156 {
3214 defsymbol (location, name); 3157 defsymbol (location, name);
3215 Fset (*location, *location); 3158 Fset (*location, *location);
3216 } 3159 }
3217 3160
3218 void
3219 defsubr (struct Lisp_Subr *subr)
3220 {
3221 Lisp_Object sym = intern (subr_name (subr));
3222
3223 #ifdef DEBUG_XEMACS 3161 #ifdef DEBUG_XEMACS
3224 /* Check that nobody spazzed writing a DEFUN. */ 3162 /* Check that nobody spazzed writing a DEFUN. */
3163 static void
3164 check_sane_subr (Lisp_Subr *subr, Lisp_Object sym)
3165 {
3225 assert (subr->min_args >= 0); 3166 assert (subr->min_args >= 0);
3226 assert (subr->min_args <= SUBR_MAX_ARGS); 3167 assert (subr->min_args <= SUBR_MAX_ARGS);
3227 3168
3228 if (subr->max_args != MANY && subr->max_args != UNEVALLED) 3169 if (subr->max_args != MANY &&
3170 subr->max_args != UNEVALLED)
3229 { 3171 {
3230 /* Need to fix lisp.h and eval.c if SUBR_MAX_ARGS too small */ 3172 /* Need to fix lisp.h and eval.c if SUBR_MAX_ARGS too small */
3231 assert (subr->max_args <= SUBR_MAX_ARGS); 3173 assert (subr->max_args <= SUBR_MAX_ARGS);
3232 assert (subr->min_args <= subr->max_args); 3174 assert (subr->min_args <= subr->max_args);
3233 } 3175 }
3234 3176
3235 assert (UNBOUNDP (XSYMBOL (sym)->function)); 3177 assert (UNBOUNDP (XSYMBOL (sym)->function));
3236 #endif /* DEBUG_XEMACS */ 3178 }
3237 3179 #else
3238 XSETSUBR (XSYMBOL (sym)->function, subr); 3180 #define check_sane_subr(subr, sym) /* nothing */
3181 #endif
3182
3183 void
3184 defsubr (Lisp_Subr *subr)
3185 {
3186 Lisp_Object sym = intern (subr_name (subr));
3187 Lisp_Object fun;
3188
3189 check_sane_subr (subr, sym);
3190
3191 XSETSUBR (fun, subr);
3192 XSYMBOL (sym)->function = fun;
3193 }
3194
3195 /* Define a lisp macro using a Lisp_Subr. */
3196 void
3197 defsubr_macro (Lisp_Subr *subr)
3198 {
3199 Lisp_Object sym = intern (subr_name (subr));
3200 Lisp_Object fun;
3201
3202 check_sane_subr (subr, sym);
3203
3204 XSETSUBR (fun, subr);
3205 XSYMBOL (sym)->function = Fcons (Qmacro, fun);
3239 } 3206 }
3240 3207
3241 void 3208 void
3242 deferror (Lisp_Object *symbol, CONST char *name, CONST char *messuhhj, 3209 deferror (Lisp_Object *symbol, CONST char *name, CONST char *messuhhj,
3243 Lisp_Object inherits_from) 3210 Lisp_Object inherits_from)
3273 defsymbol (&Qfboundp, "fboundp"); 3240 defsymbol (&Qfboundp, "fboundp");
3274 defsymbol (&Qglobally_boundp, "globally-boundp"); 3241 defsymbol (&Qglobally_boundp, "globally-boundp");
3275 defsymbol (&Qmakunbound, "makunbound"); 3242 defsymbol (&Qmakunbound, "makunbound");
3276 defsymbol (&Qsymbol_value, "symbol-value"); 3243 defsymbol (&Qsymbol_value, "symbol-value");
3277 defsymbol (&Qset, "set"); 3244 defsymbol (&Qset, "set");
3245 defsymbol (&Qsetq_default, "setq-default");
3278 defsymbol (&Qdefault_boundp, "default-boundp"); 3246 defsymbol (&Qdefault_boundp, "default-boundp");
3279 defsymbol (&Qdefault_value, "default-value"); 3247 defsymbol (&Qdefault_value, "default-value");
3280 defsymbol (&Qset_default, "set-default"); 3248 defsymbol (&Qset_default, "set-default");
3281 defsymbol (&Qmake_variable_buffer_local, "make-variable-buffer-local"); 3249 defsymbol (&Qmake_variable_buffer_local, "make-variable-buffer-local");
3282 defsymbol (&Qmake_local_variable, "make-local-variable"); 3250 defsymbol (&Qmake_local_variable, "make-local-variable");
3311 DEFSUBR (Fboundp); 3279 DEFSUBR (Fboundp);
3312 DEFSUBR (Fglobally_boundp); 3280 DEFSUBR (Fglobally_boundp);
3313 DEFSUBR (Ffboundp); 3281 DEFSUBR (Ffboundp);
3314 DEFSUBR (Ffset); 3282 DEFSUBR (Ffset);
3315 DEFSUBR (Fdefine_function); 3283 DEFSUBR (Fdefine_function);
3284 Ffset (intern ("defalias"), intern ("define-function"));
3316 DEFSUBR (Fsetplist); 3285 DEFSUBR (Fsetplist);
3317 DEFSUBR (Fsymbol_value_in_buffer); 3286 DEFSUBR (Fsymbol_value_in_buffer);
3318 DEFSUBR (Fsymbol_value_in_console); 3287 DEFSUBR (Fsymbol_value_in_console);
3319 DEFSUBR (Fbuilt_in_variable_type); 3288 DEFSUBR (Fbuilt_in_variable_type);
3320 DEFSUBR (Fsymbol_value); 3289 DEFSUBR (Fsymbol_value);
3332 DEFSUBR (Fvariable_alias); 3301 DEFSUBR (Fvariable_alias);
3333 DEFSUBR (Findirect_variable); 3302 DEFSUBR (Findirect_variable);
3334 DEFSUBR (Fdontusethis_set_symbol_value_handler); 3303 DEFSUBR (Fdontusethis_set_symbol_value_handler);
3335 } 3304 }
3336 3305
3337 /* Create and initialize a variable whose value is forwarded to C data */ 3306 /* Create and initialize a Lisp variable whose value is forwarded to C data */
3338 void 3307 void
3339 defvar_mumble (CONST char *namestring, CONST void *magic, size_t sizeof_magic) 3308 defvar_magic (CONST char *symbol_name, CONST struct symbol_value_forward *magic)
3340 { 3309 {
3341 Lisp_Object kludge; 3310 Lisp_Object sym, kludge;
3342 Lisp_Object sym = Fintern (make_pure_pname ((CONST Bufbyte *) namestring, 3311
3343 strlen (namestring), 3312 /* Check that `magic' points somewhere we can represent as a Lisp pointer */
3344 1),
3345 Qnil);
3346
3347 /* Check that magic points somewhere we can represent as a Lisp pointer */
3348 XSETOBJ (kludge, Lisp_Type_Record, magic); 3313 XSETOBJ (kludge, Lisp_Type_Record, magic);
3349 if (magic != (CONST void *) XPNTR (kludge)) 3314 if ((void *)magic != (void*) XPNTR (kludge))
3350 { 3315 {
3351 /* This might happen on DATA_SEG_BITS machines. */ 3316 /* This might happen on DATA_SEG_BITS machines. */
3352 /* abort (); */ 3317 /* abort (); */
3353 /* Copy it to somewhere which is representable. */ 3318 /* Copy it to somewhere which is representable. */
3354 void *f = xmalloc (sizeof_magic); 3319 struct symbol_value_forward *p = xnew (struct symbol_value_forward);
3355 memcpy (f, magic, sizeof_magic); 3320 memcpy (p, magic, sizeof *magic);
3356 XSETOBJ (XSYMBOL (sym)->value, Lisp_Type_Record, f); 3321 magic = p;
3357 } 3322 }
3358 else 3323
3359 XSETOBJ (XSYMBOL (sym)->value, Lisp_Type_Record, magic); 3324 sym = Fintern (make_pure_pname ((CONST Bufbyte *) symbol_name,
3325 strlen (symbol_name),
3326 1),
3327 Qnil);
3328 XSETOBJ (XSYMBOL (sym)->value, Lisp_Type_Record, magic);
3360 } 3329 }
3361 3330
3362 void 3331 void
3363 vars_of_symbols (void) 3332 vars_of_symbols (void)
3364 { 3333 {