git.chise.org Git - chise/xemacs-chise.git.1/blob - src/symbols.c

   1 /* "intern" and friends -- moved here from lread.c and data.c
   2    Copyright (C) 1985-1989, 1992-1994 Free Software Foundation, Inc.
   3    Copyright (C) 1995 Ben Wing.
   4
   5 This file is part of XEmacs.
   6
   7 XEmacs is free software; you can redistribute it and/or modify it
   8 under the terms of the GNU General Public License as published by the
   9 Free Software Foundation; either version 2, or (at your option) any
  10 later version.
  11
  12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with XEmacs; see the file COPYING.  If not, write to
  19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 Boston, MA 02111-1307, USA.  */
  21
  22 /* Synched up with: FSF 19.30. */
  23
  24 /* This file has been Mule-ized. */
  25
  26 /* NOTE:
  27
  28    The value cell of a symbol can contain a simple value or one of
  29    various symbol-value-magic objects.  Some of these objects can
  30    chain into other kinds of objects.  Here is a table of possibilities:
  31
  32    1a) simple value
  33    1b) Qunbound
  34    1c) symbol-value-forward, excluding Qunbound
  35    2) symbol-value-buffer-local -> 1a or 1b or 1c
  36    3) symbol-value-lisp-magic -> 1a or 1b or 1c
  37    4) symbol-value-lisp-magic -> symbol-value-buffer-local -> 1a or 1b or 1c
  38    5) symbol-value-varalias
  39    6) symbol-value-lisp-magic -> symbol-value-varalias
  40
  41    The "chain" of a symbol-value-buffer-local is its current_value slot.
  42
  43    The "chain" of a symbol-value-lisp-magic is its shadowed slot, which
  44    applies for handler types without associated handlers.
  45
  46    All other fields in all the structures (including the "shadowed" slot
  47    in a symbol-value-varalias) can *only* contain a simple value or Qunbound.
  48
  49 */
  50
  51 /* #### Ugh, though, this file does awful things with symbol-value-magic
  52    objects.  This ought to be cleaned up. */
  53
  54 #include <config.h>
  55 #include "lisp.h"
  56
  57 #include "buffer.h"             /* for Vbuffer_defaults */
  58 #include "console.h"
  59 #include "elhash.h"
  60
  61 Lisp_Object Qad_advice_info, Qad_activate;
  62
  63 Lisp_Object Qget_value, Qset_value, Qbound_predicate, Qmake_unbound;
  64 Lisp_Object Qlocal_predicate, Qmake_local;
  65
  66 Lisp_Object Qboundp, Qfboundp, Qglobally_boundp, Qmakunbound;
  67 Lisp_Object Qsymbol_value, Qset, Qdefault_boundp, Qdefault_value;
  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;
  71 Lisp_Object Qsymbol_value_in_buffer, Qsymbol_value_in_console;
  72 Lisp_Object Qlocal_variable_p;
  73
  74 Lisp_Object Qconst_integer, Qconst_boolean, Qconst_object;
  75 Lisp_Object Qconst_specifier;
  76 Lisp_Object Qdefault_buffer, Qcurrent_buffer, Qconst_current_buffer;
  77 Lisp_Object Qdefault_console, Qselected_console, Qconst_selected_console;
  78
  79 static Lisp_Object maybe_call_magic_handler (Lisp_Object sym,
  80                                              Lisp_Object funsym,
  81                                              int nargs, ...);
  82 static Lisp_Object fetch_value_maybe_past_magic (Lisp_Object sym,
  83                                                  Lisp_Object follow_past_lisp_magic);
  84 static Lisp_Object *value_slot_past_magic (Lisp_Object sym);
  85 static Lisp_Object follow_varalias_pointers (Lisp_Object symbol,
  86                                              Lisp_Object follow_past_lisp_magic);
  87
  88 \f
  89 static Lisp_Object
  90 mark_symbol (Lisp_Object obj, void (*markobj) (Lisp_Object))
  91 {
  92   struct Lisp_Symbol *sym = XSYMBOL (obj);
  93   Lisp_Object pname;
  94
  95   markobj (sym->value);
  96   markobj (sym->function);
  97   XSETSTRING (pname, sym->name);
  98   markobj (pname);
  99   if (!symbol_next (sym))
 100     return sym->plist;
 101   else
 102   {
 103     markobj (sym->plist);
 104     /* Mark the rest of the symbols in the obarray hash-chain */
 105     sym = symbol_next (sym);
 106     XSETSYMBOL (obj, sym);
 107     return obj;
 108   }
 109 }
 110
 111 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("symbol", symbol,
 112                                      mark_symbol, print_symbol, 0, 0, 0,
 113                                      struct Lisp_Symbol);
 114
 115 \f
 116 /**********************************************************************/
 117 /*                              Intern                                */
 118 /**********************************************************************/
 119
 120 /* #### using a vector here is way bogus.  Use a hash table instead. */
 121
 122 Lisp_Object Vobarray;
 123
 124 static Lisp_Object initial_obarray;
 125
 126 /* oblookup stores the bucket number here, for the sake of Funintern.  */
 127
 128 static int oblookup_last_bucket_number;
 129
 130 static Lisp_Object
 131 check_obarray (Lisp_Object obarray)
 132 {
 133   while (!VECTORP (obarray) || XVECTOR_LENGTH (obarray) == 0)
 134     {
 135       /* If Vobarray is now invalid, force it to be valid.  */
 136       if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
 137
 138       obarray = wrong_type_argument (Qvectorp, obarray);
 139     }
 140   return obarray;
 141 }
 142
 143 Lisp_Object
 144 intern (CONST char *str)
 145 {
 146   Bytecount len = strlen (str);
 147   CONST Bufbyte *buf = (CONST Bufbyte *) str;
 148   Lisp_Object obarray = Vobarray;
 149
 150   if (!VECTORP (obarray) || XVECTOR_LENGTH (obarray) == 0)
 151     obarray = check_obarray (obarray);
 152
 153   {
 154     Lisp_Object tem = oblookup (obarray, buf, len);
 155     if (SYMBOLP (tem))
 156       return tem;
 157   }
 158
 159   return Fintern (make_string (buf, len), obarray);
 160 }
 161
 162 DEFUN ("intern", Fintern, 1, 2, 0, /*
 163 Return the canonical symbol whose name is STRING.
 164 If there is none, one is created by this function and returned.
 165 A second optional argument specifies the obarray to use;
 166 it defaults to the value of `obarray'.
 167 */
 168        (string, obarray))
 169 {
 170   Lisp_Object object, *ptr;
 171   struct Lisp_Symbol *symbol;
 172   Bytecount len;
 173
 174   if (NILP (obarray)) obarray = Vobarray;
 175   obarray = check_obarray (obarray);
 176
 177   CHECK_STRING (string);
 178
 179   len = XSTRING_LENGTH (string);
 180   object = oblookup (obarray, XSTRING_DATA (string), len);
 181   if (!INTP (object))
 182     /* Found it */
 183     return object;
 184
 185   ptr = &XVECTOR_DATA (obarray)[XINT (object)];
 186
 187   object = Fmake_symbol (string);
 188   symbol = XSYMBOL (object);
 189
 190   if (SYMBOLP (*ptr))
 191     symbol_next (symbol) = XSYMBOL (*ptr);
 192   else
 193     symbol_next (symbol) = 0;
 194   *ptr = object;
 195
 196   if (string_byte (symbol_name (symbol), 0) == ':' && EQ (obarray, Vobarray))
 197     {
 198       /* The LISP way is to put keywords in their own package, but we
 199          don't have packages, so we do something simpler.  Someday,
 200          maybe we'll have packages and then this will be reworked.
 201          --Stig. */
 202       symbol_value (symbol) = object;
 203     }
 204
 205   return object;
 206 }
 207
 208 DEFUN ("intern-soft", Fintern_soft, 1, 2, 0, /*
 209 Return the canonical symbol named NAME, or nil if none exists.
 210 NAME may be a string or a symbol.  If it is a symbol, that exact
 211 symbol is searched for.
 212 A second optional argument specifies the obarray to use;
 213 it defaults to the value of `obarray'.
 214 */
 215        (name, obarray))
 216 {
 217   /* #### Bug!  (intern-soft "nil") returns nil.  Perhaps we should
 218      add a DEFAULT-IF-NOT-FOUND arg, like in get.  */
 219   Lisp_Object tem;
 220   struct Lisp_String *string;
 221
 222   if (NILP (obarray)) obarray = Vobarray;
 223   obarray = check_obarray (obarray);
 224
 225   if (!SYMBOLP (name))
 226     {
 227       CHECK_STRING (name);
 228       string = XSTRING (name);
 229     }
 230   else
 231     string = symbol_name (XSYMBOL (name));
 232
 233   tem = oblookup (obarray, string_data (string), string_length (string));
 234   if (INTP (tem) || (SYMBOLP (name) && !EQ (name, tem)))
 235     return Qnil;
 236   else
 237     return tem;
 238 }
 239 \f
 240 DEFUN ("unintern", Funintern, 1, 2, 0, /*
 241 Delete the symbol named NAME, if any, from OBARRAY.
 242 The value is t if a symbol was found and deleted, nil otherwise.
 243 NAME may be a string or a symbol.  If it is a symbol, that symbol
 244 is deleted, if it belongs to OBARRAY--no other symbol is deleted.
 245 OBARRAY defaults to the value of the variable `obarray'
 246 */
 247        (name, obarray))
 248 {
 249   Lisp_Object tem;
 250   struct Lisp_String *string;
 251   int hash;
 252
 253   if (NILP (obarray)) obarray = Vobarray;
 254   obarray = check_obarray (obarray);
 255
 256   if (SYMBOLP (name))
 257     string = symbol_name (XSYMBOL (name));
 258   else
 259     {
 260       CHECK_STRING (name);
 261       string = XSTRING (name);
 262     }
 263
 264   tem = oblookup (obarray, string_data (string), string_length (string));
 265   if (INTP (tem))
 266     return Qnil;
 267   /* If arg was a symbol, don't delete anything but that symbol itself.  */
 268   if (SYMBOLP (name) && !EQ (name, tem))
 269     return Qnil;
 270
 271   hash = oblookup_last_bucket_number;
 272
 273   if (EQ (XVECTOR_DATA (obarray)[hash], tem))
 274     {
 275       if (XSYMBOL (tem)->next)
 276         XSETSYMBOL (XVECTOR_DATA (obarray)[hash], XSYMBOL (tem)->next);
 277       else
 278         XVECTOR_DATA (obarray)[hash] = Qzero;
 279     }
 280   else
 281     {
 282       Lisp_Object tail, following;
 283
 284       for (tail = XVECTOR_DATA (obarray)[hash];
 285            XSYMBOL (tail)->next;
 286            tail = following)
 287         {
 288           XSETSYMBOL (following, XSYMBOL (tail)->next);
 289           if (EQ (following, tem))
 290             {
 291               XSYMBOL (tail)->next = XSYMBOL (following)->next;
 292               break;
 293             }
 294         }
 295     }
 296   return Qt;
 297 }
 298 \f
 299 /* Return the symbol in OBARRAY whose names matches the string
 300    of SIZE characters at PTR.  If there is no such symbol in OBARRAY,
 301    return the index into OBARRAY that the string hashes to.
 302
 303    Also store the bucket number in oblookup_last_bucket_number.  */
 304
 305 Lisp_Object
 306 oblookup (Lisp_Object obarray, CONST Bufbyte *ptr, Bytecount size)
 307 {
 308   int hash, obsize;
 309   struct Lisp_Symbol *tail;
 310   Lisp_Object bucket;
 311
 312   if (!VECTORP (obarray) ||
 313       (obsize = XVECTOR_LENGTH (obarray)) == 0)
 314     {
 315       obarray = check_obarray (obarray);
 316       obsize = XVECTOR_LENGTH (obarray);
 317     }
 318   hash = hash_string (ptr, size) % obsize;
 319   oblookup_last_bucket_number = hash;
 320   bucket = XVECTOR_DATA (obarray)[hash];
 321   if (ZEROP (bucket))
 322     ;
 323   else if (!SYMBOLP (bucket))
 324     error ("Bad data in guts of obarray"); /* Like CADR error message */
 325   else
 326     for (tail = XSYMBOL (bucket); ;)
 327       {
 328         if (string_length (tail->name) == size &&
 329             !memcmp (string_data (tail->name), ptr, size))
 330           {
 331             XSETSYMBOL (bucket, tail);
 332             return bucket;
 333           }
 334         tail = symbol_next (tail);
 335         if (!tail)
 336           break;
 337       }
 338   return make_int (hash);
 339 }
 340
 341 #if 0 /* Emacs 19.34 */
 342 int
 343 hash_string (CONST Bufbyte *ptr, Bytecount len)
 344 {
 345   CONST Bufbyte *p = ptr;
 346   CONST Bufbyte *end = p + len;
 347   Bufbyte c;
 348   int hash = 0;
 349
 350   while (p != end)
 351     {
 352       c = *p++;
 353       if (c >= 0140) c -= 40;
 354       hash = ((hash<<3) + (hash>>28) + c);
 355     }
 356   return hash & 07777777777;
 357 }
 358 #endif
 359
 360 /* derived from hashpjw, Dragon Book P436. */
 361 int
 362 hash_string (CONST Bufbyte *ptr, Bytecount len)
 363 {
 364   int hash = 0;
 365
 366   while (len-- > 0)
 367     {
 368       int g;
 369       hash = (hash << 4) + *ptr++;
 370       g = hash & 0xf0000000;
 371       if (g)
 372         hash = (hash ^ (g >> 24)) ^ g;
 373     }
 374   return hash & 07777777777;
 375 }
 376
 377 /* Map FN over OBARRAY.  The mapping is stopped when FN returns a
 378    non-zero value.  */
 379 void
 380 map_obarray (Lisp_Object obarray,
 381              int (*fn) (Lisp_Object, void *), void *arg)
 382 {
 383   REGISTER int i;
 384
 385   CHECK_VECTOR (obarray);
 386   for (i = XVECTOR_LENGTH (obarray) - 1; i >= 0; i--)
 387     {
 388       Lisp_Object tail = XVECTOR_DATA (obarray)[i];
 389       if (SYMBOLP (tail))
 390         while (1)
 391           {
 392             struct Lisp_Symbol *next;
 393             if ((*fn) (tail, arg))
 394               return;
 395             next = symbol_next (XSYMBOL (tail));
 396             if (!next)
 397               break;
 398             XSETSYMBOL (tail, next);
 399           }
 400     }
 401 }
 402
 403 static int
 404 mapatoms_1 (Lisp_Object sym, void *arg)
 405 {
 406   call1 (*(Lisp_Object *)arg, sym);
 407   return 0;
 408 }
 409
 410 DEFUN ("mapatoms", Fmapatoms, 1, 2, 0, /*
 411 Call FUNCTION on every symbol in OBARRAY.
 412 OBARRAY defaults to the value of `obarray'.
 413 */
 414        (function, obarray))
 415 {
 416   if (NILP (obarray))
 417     obarray = Vobarray;
 418   obarray = check_obarray (obarray);
 419
 420   map_obarray (obarray, mapatoms_1, &function);
 421   return Qnil;
 422 }
 423
 424 \f
 425 /**********************************************************************/
 426 /*                              Apropos                               */
 427 /**********************************************************************/
 428
 429 struct appropos_mapper_closure
 430 {
 431   Lisp_Object regexp;
 432   Lisp_Object predicate;
 433   Lisp_Object accumulation;
 434 };
 435
 436 static int
 437 apropos_mapper (Lisp_Object symbol, void *arg)
 438 {
 439   struct appropos_mapper_closure *closure =
 440     (struct appropos_mapper_closure *) arg;
 441   Bytecount match = fast_lisp_string_match (closure->regexp,
 442                                             Fsymbol_name (symbol));
 443
 444   if (match >= 0 &&
 445       (NILP (closure->predicate) ||
 446        !NILP (call1 (closure->predicate, symbol))))
 447     closure->accumulation = Fcons (symbol, closure->accumulation);
 448
 449   return 0;
 450 }
 451
 452 DEFUN ("apropos-internal", Fapropos_internal, 1, 2, 0, /*
 453 Show all symbols whose names contain match for REGEXP.
 454 If optional 2nd arg PREDICATE is non-nil, (funcall PREDICATE SYMBOL)
 455  is done for each symbol and a symbol is mentioned only if that
 456  returns non-nil.
 457 Return list of symbols found.
 458 */
 459        (regexp, predicate))
 460 {
 461   struct appropos_mapper_closure closure;
 462
 463   CHECK_STRING (regexp);
 464
 465   closure.regexp = regexp;
 466   closure.predicate = predicate;
 467   closure.accumulation = Qnil;
 468   map_obarray (Vobarray, apropos_mapper, &closure);
 469   closure.accumulation = Fsort (closure.accumulation, Qstring_lessp);
 470   return closure.accumulation;
 471 }
 472
 473 \f
 474 /* Extract and set components of symbols */
 475
 476 static void set_up_buffer_local_cache (Lisp_Object sym,
 477                                        struct symbol_value_buffer_local *bfwd,
 478                                        struct buffer *buf,
 479                                        Lisp_Object new_alist_el,
 480                                        int set_it_p);
 481
 482 DEFUN ("boundp", Fboundp, 1, 1, 0, /*
 483 Return t if SYMBOL's value is not void.
 484 */
 485        (symbol))
 486 {
 487   CHECK_SYMBOL (symbol);
 488   return UNBOUNDP (find_symbol_value (symbol)) ? Qnil : Qt;
 489 }
 490
 491 DEFUN ("globally-boundp", Fglobally_boundp, 1, 1, 0, /*
 492 Return t if SYMBOL has a global (non-bound) value.
 493 This is for the byte-compiler; you really shouldn't be using this.
 494 */
 495        (symbol))
 496 {
 497   CHECK_SYMBOL (symbol);
 498   return UNBOUNDP (top_level_value (symbol)) ? Qnil : Qt;
 499 }
 500
 501 DEFUN ("fboundp", Ffboundp, 1, 1, 0, /*
 502 Return t if SYMBOL's function definition is not void.
 503 */
 504        (symbol))
 505 {
 506   CHECK_SYMBOL (symbol);
 507   return UNBOUNDP (XSYMBOL (symbol)->function) ? Qnil : Qt;
 508 }
 509
 510 /* Return non-zero if SYM's value or function (the current contents of
 511    which should be passed in as VAL) is constant, i.e. unsettable. */
 512
 513 static int
 514 symbol_is_constant (Lisp_Object sym, Lisp_Object val)
 515 {
 516   /* #### - I wonder if it would be better to just have a new magic value
 517      type and make nil, t, and all keywords have that same magic
 518      constant_symbol value.  This test is awfully specific about what is
 519      constant and what isn't.  --Stig */
 520   if (EQ (sym, Qnil) ||
 521       EQ (sym, Qt))
 522     return 1;
 523
 524   if (SYMBOL_VALUE_MAGIC_P (val))
 525     switch (XSYMBOL_VALUE_MAGIC_TYPE (val))
 526       {
 527       case SYMVAL_CONST_OBJECT_FORWARD:
 528       case SYMVAL_CONST_SPECIFIER_FORWARD:
 529       case SYMVAL_CONST_FIXNUM_FORWARD:
 530       case SYMVAL_CONST_BOOLEAN_FORWARD:
 531       case SYMVAL_CONST_CURRENT_BUFFER_FORWARD:
 532       case SYMVAL_CONST_SELECTED_CONSOLE_FORWARD:
 533         return 1;
 534       default: break; /* Warning suppression */
 535       }
 536
 537   /* We don't return true for keywords here because they are handled
 538      specially by reject_constant_symbols().  */
 539   return 0;
 540 }
 541
 542 /* We are setting SYM's value slot (or function slot, if FUNCTION_P is
 543    non-zero) to NEWVAL.  Make sure this is allowed.
 544    FOLLOW_PAST_LISP_MAGIC specifies whether we delve past
 545    symbol-value-lisp-magic objects.  */
 546
 547 void
 548 reject_constant_symbols (Lisp_Object sym, Lisp_Object newval, int function_p,
 549                          Lisp_Object follow_past_lisp_magic)
 550 {
 551   Lisp_Object val =
 552     (function_p ? XSYMBOL (sym)->function
 553      : fetch_value_maybe_past_magic (sym, follow_past_lisp_magic));
 554
 555   if (SYMBOL_VALUE_MAGIC_P (val) &&
 556       XSYMBOL_VALUE_MAGIC_TYPE (val) == SYMVAL_CONST_SPECIFIER_FORWARD)
 557     signal_simple_error ("Use `set-specifier' to change a specifier's value",
 558                          sym);
 559
 560   if (symbol_is_constant (sym, val)
 561       || (SYMBOL_IS_KEYWORD (sym) && !EQ (newval, sym)))
 562     signal_error (Qsetting_constant,
 563                   UNBOUNDP (newval) ? list1 (sym) : list2 (sym, newval));
 564 }
 565
 566 /* Verify that it's ok to make SYM buffer-local.  This rejects
 567    constants and default-buffer-local variables.  FOLLOW_PAST_LISP_MAGIC
 568    specifies whether we delve into symbol-value-lisp-magic objects.
 569    (Should be a symbol indicating what action is being taken; that way,
 570    we don't delve if there's a handler for that action, but do otherwise.) */
 571
 572 static void
 573 verify_ok_for_buffer_local (Lisp_Object sym,
 574                             Lisp_Object follow_past_lisp_magic)
 575 {
 576   Lisp_Object val = fetch_value_maybe_past_magic (sym, follow_past_lisp_magic);
 577
 578   if (symbol_is_constant (sym, val))
 579     goto not_ok;
 580   if (SYMBOL_VALUE_MAGIC_P (val))
 581     switch (XSYMBOL_VALUE_MAGIC_TYPE (val))
 582       {
 583         case SYMVAL_DEFAULT_BUFFER_FORWARD:
 584         case SYMVAL_DEFAULT_CONSOLE_FORWARD:
 585           /* #### It's theoretically possible for it to be reasonable
 586              to have both console-local and buffer-local variables,
 587              but I don't want to consider that right now. */
 588         case SYMVAL_SELECTED_CONSOLE_FORWARD:
 589           goto not_ok;
 590       default: break; /* Warning suppression */
 591       }
 592
 593   return;
 594
 595   not_ok:
 596   signal_error (Qerror,
 597                 list2 (build_string ("Symbol may not be buffer-local"), sym));
 598 }
 599
 600 DEFUN ("makunbound", Fmakunbound, 1, 1, 0, /*
 601 Make SYMBOL's value be void.
 602 */
 603        (symbol))
 604 {
 605   Fset (symbol, Qunbound);
 606   return symbol;
 607 }
 608
 609 DEFUN ("fmakunbound", Ffmakunbound, 1, 1, 0, /*
 610 Make SYMBOL's function definition be void.
 611 */
 612        (symbol))
 613 {
 614   CHECK_SYMBOL (symbol);
 615   reject_constant_symbols (symbol, Qunbound, 1, Qt);
 616   XSYMBOL (symbol)->function = Qunbound;
 617   return symbol;
 618 }
 619
 620 DEFUN ("symbol-function", Fsymbol_function, 1, 1, 0, /*
 621 Return SYMBOL's function definition.  Error if that is void.
 622 */
 623        (symbol))
 624 {
 625   CHECK_SYMBOL (symbol);
 626   if (UNBOUNDP (XSYMBOL (symbol)->function))
 627     signal_void_function_error (symbol);
 628   return XSYMBOL (symbol)->function;
 629 }
 630
 631 DEFUN ("symbol-plist", Fsymbol_plist, 1, 1, 0, /*
 632 Return SYMBOL's property list.
 633 */
 634        (symbol))
 635 {
 636   CHECK_SYMBOL (symbol);
 637   return XSYMBOL (symbol)->plist;
 638 }
 639
 640 DEFUN ("symbol-name", Fsymbol_name, 1, 1, 0, /*
 641 Return SYMBOL's name, a string.
 642 */
 643        (symbol))
 644 {
 645   Lisp_Object name;
 646
 647   CHECK_SYMBOL (symbol);
 648   XSETSTRING (name, XSYMBOL (symbol)->name);
 649   return name;
 650 }
 651
 652 DEFUN ("fset", Ffset, 2, 2, 0, /*
 653 Set SYMBOL's function definition to NEWDEF, and return NEWDEF.
 654 */
 655        (symbol, newdef))
 656 {
 657   /* This function can GC */
 658   CHECK_SYMBOL (symbol);
 659   reject_constant_symbols (symbol, newdef, 1, Qt);
 660   if (!NILP (Vautoload_queue) && !UNBOUNDP (XSYMBOL (symbol)->function))
 661     Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
 662                              Vautoload_queue);
 663   XSYMBOL (symbol)->function = newdef;
 664   /* Handle automatic advice activation */
 665   if (CONSP (XSYMBOL (symbol)->plist) &&
 666       !NILP (Fget (symbol, Qad_advice_info, Qnil)))
 667     {
 668       call2 (Qad_activate, symbol, Qnil);
 669       newdef = XSYMBOL (symbol)->function;
 670     }
 671   return newdef;
 672 }
 673
 674 /* FSFmacs */
 675 DEFUN ("define-function", Fdefine_function, 2, 2, 0, /*
 676 Set SYMBOL's function definition to NEWDEF, and return NEWDEF.
 677 Associates the function with the current load file, if any.
 678 */
 679        (symbol, newdef))
 680 {
 681   /* This function can GC */
 682   Ffset (symbol, newdef);
 683   LOADHIST_ATTACH (symbol);
 684   return newdef;
 685 }
 686
 687
 688 DEFUN ("setplist", Fsetplist, 2, 2, 0, /*
 689 Set SYMBOL's property list to NEWPLIST, and return NEWPLIST.
 690 */
 691        (symbol, newplist))
 692 {
 693   CHECK_SYMBOL (symbol);
 694 #if 0 /* Inserted for debugging 6/28/1997 -slb */
 695   /* Somebody is setting a property list of integer 0, who? */
 696   /* Not this way apparently. */
 697   if (EQ(newplist, Qzero)) abort();
 698 #endif
 699
 700   XSYMBOL (symbol)->plist = newplist;
 701   return newplist;
 702 }
 703
 704 \f
 705 /**********************************************************************/
 706 /*                           symbol-value                             */
 707 /**********************************************************************/
 708
 709 /* If the contents of the value cell of a symbol is one of the following
 710    three types of objects, then the symbol is "magic" in that setting
 711    and retrieving its value doesn't just set or retrieve the raw
 712    contents of the value cell.  None of these objects can escape to
 713    the user level, so there is no loss of generality.
 714
 715    If a symbol is "unbound", then the contents of its value cell is
 716    Qunbound.  Despite appearances, this is *not* a symbol, but is a
 717    symbol-value-forward object.  This is so that printing it results
 718    in "INTERNAL OBJECT (XEmacs bug?)", in case it leaks to Lisp, somehow.
 719
 720    Logically all of the following objects are "symbol-value-magic"
 721    objects, and there are some games played w.r.t. this (#### this
 722    should be cleaned up).  SYMBOL_VALUE_MAGIC_P is true for all of
 723    the object types.  XSYMBOL_VALUE_MAGIC_TYPE returns the type of
 724    symbol-value-magic object.  There are more than three types
 725    returned by this macro: in particular, symbol-value-forward
 726    has eight subtypes, and symbol-value-buffer-local has two.  See
 727    symeval.h.
 728
 729    1. symbol-value-forward
 730
 731    symbol-value-forward is used for variables whose actual contents
 732    are stored in a C variable of some sort, and for Qunbound.  The
 733    lcheader.next field (which is only used to chain together free
 734    lcrecords) holds a pointer to the actual C variable.  Included
 735    in this type are "buffer-local" variables that are actually
 736    stored in the buffer object itself; in this case, the "pointer"
 737    is an offset into the struct buffer structure.
 738
 739    The subtypes are as follows:
 740
 741    SYMVAL_OBJECT_FORWARD:
 742       (declare with DEFVAR_LISP)
 743       The value of this variable is stored in a C variable of type
 744       "Lisp_Object".  Setting this variable sets the C variable.
 745       Accessing this variable retrieves a value from the C variable.
 746       These variables can be buffer-local -- in this case, the
 747       raw symbol-value field gets converted into a
 748       symbol-value-buffer-local, whose "current_value" slot contains
 749       the symbol-value-forward. (See below.)
 750
 751    SYMVAL_FIXNUM_FORWARD:
 752    SYMVAL_BOOLEAN_FORWARD:
 753       (declare with DEFVAR_INT or DEFVAR_BOOL)
 754       Similar to SYMVAL_OBJECT_FORWARD except that the C variable
 755       is of type "int" and is an integer or boolean, respectively.
 756
 757    SYMVAL_CONST_OBJECT_FORWARD:
 758    SYMVAL_CONST_FIXNUM_FORWARD:
 759    SYMVAL_CONST_BOOLEAN_FORWARD:
 760       (declare with DEFVAR_CONST_LISP, DEFVAR_CONST_INT, or
 761        DEFVAR_CONST_BOOL)
 762       Similar to SYMVAL_OBJECT_FORWARD, SYMVAL_FIXNUM_FORWARD, or
 763       SYMVAL_BOOLEAN_FORWARD, respectively, except that the value cannot
 764       be changed.
 765
 766    SYMVAL_CONST_SPECIFIER_FORWARD:
 767       (declare with DEFVAR_SPECIFIER)
 768       Exactly like SYMVAL_CONST_OBJECT_FORWARD except that error message
 769       you get when attempting to set the value says to use
 770       `set-specifier' instead.
 771
 772    SYMVAL_CURRENT_BUFFER_FORWARD:
 773       (declare with DEFVAR_BUFFER_LOCAL)
 774       This is used for built-in buffer-local variables -- i.e.
 775       Lisp variables whose value is stored in the "struct buffer".
 776       Variables of this sort always forward into C "Lisp_Object"
 777       fields (although there's no reason in principle that other
 778       types for ints and booleans couldn't be added).  Note that
 779       some of these variables are automatically local in each
 780       buffer, while some are only local when they become set
 781       (similar to `make-variable-buffer-local').  In these latter
 782       cases, of course, the default value shows through in all
 783       buffers in which the variable doesn't have a local value.
 784       This is implemented by making sure the "struct buffer" field
 785       always contains the correct value (whether it's local or
 786       a default) and maintaining a mask in the "struct buffer"
 787       indicating which fields are local.  When `set-default' is
 788       called on a variable that's not always local to all buffers,
 789       it loops through each buffer and sets the corresponding
 790       field in each buffer without a local value for the field,
 791       according to the mask.
 792
 793       Calling `make-local-variable' on a variable of this sort
 794       only has the effect of maybe changing the current buffer's mask.
 795       Calling `make-variable-buffer-local' on a variable of this
 796       sort has no effect at all.
 797
 798    SYMVAL_CONST_CURRENT_BUFFER_FORWARD:
 799       (declare with DEFVAR_CONST_BUFFER_LOCAL)
 800       Same as SYMVAL_CURRENT_BUFFER_FORWARD except that the
 801       value cannot be set.
 802
 803    SYMVAL_DEFAULT_BUFFER_FORWARD:
 804       (declare with DEFVAR_BUFFER_DEFAULTS)
 805       This is used for the Lisp variables that contain the
 806       default values of built-in buffer-local variables.  Setting
 807       or referencing one of these variables forwards into a slot
 808       in the special struct buffer Vbuffer_defaults.
 809
 810    SYMVAL_UNBOUND_MARKER:
 811       This is used for only one object, Qunbound.
 812
 813    SYMVAL_SELECTED_CONSOLE_FORWARD:
 814       (declare with DEFVAR_CONSOLE_LOCAL)
 815       This is used for built-in console-local variables -- i.e.
 816       Lisp variables whose value is stored in the "struct console".
 817       These work just like built-in buffer-local variables.
 818       However, calling `make-local-variable' or
 819       `make-variable-buffer-local' on one of these variables
 820       is currently disallowed because that would entail having
 821       both console-local and buffer-local variables, which is
 822       trickier to implement.
 823
 824    SYMVAL_CONST_SELECTED_CONSOLE_FORWARD:
 825       (declare with DEFVAR_CONST_CONSOLE_LOCAL)
 826       Same as SYMVAL_SELECTED_CONSOLE_FORWARD except that the
 827       value cannot be set.
 828
 829    SYMVAL_DEFAULT_CONSOLE_FORWARD:
 830       (declare with DEFVAR_CONSOLE_DEFAULTS)
 831       This is used for the Lisp variables that contain the
 832       default values of built-in console-local variables.  Setting
 833       or referencing one of these variables forwards into a slot
 834       in the special struct console Vconsole_defaults.
 835
 836
 837    2. symbol-value-buffer-local
 838
 839    symbol-value-buffer-local is used for variables that have had
 840    `make-local-variable' or `make-variable-buffer-local' applied
 841    to them.  This object contains an alist mapping buffers to
 842    values.  In addition, the object contains a "current value",
 843    which is the value in some buffer.  Whenever you access the
 844    variable with `symbol-value' or set it with `set' or `setq',
 845    things are switched around so that the "current value"
 846    refers to the current buffer, if it wasn't already.  This
 847    way, repeated references to a variable in the same buffer
 848    are almost as efficient as if the variable weren't buffer
 849    local.  Note that the alist may not be up-to-date w.r.t.
 850    the buffer whose value is current, as the "current value"
 851    cache is normally only flushed into the alist when the
 852    buffer it refers to changes.
 853
 854    Note also that it is possible for `make-local-variable'
 855    or `make-variable-buffer-local' to be called on a variable
 856    that forwards into a C variable (i.e. a variable whose
 857    value cell is a symbol-value-forward).  In this case,
 858    the value cell becomes a symbol-value-buffer-local (as
 859    always), and the symbol-value-forward moves into
 860    the "current value" cell in this object.  Also, in
 861    this case the "current value" *always* refers to the
 862    current buffer, so that the values of the C variable
 863    always is the correct value for the current buffer.
 864    set_buffer_internal() automatically updates the current-value
 865    cells of all buffer-local variables that forward into C
 866    variables. (There is a list of all buffer-local variables
 867    that is maintained for this and other purposes.)
 868
 869    Note that only certain types of `symbol-value-forward' objects
 870    can find their way into the "current value" cell of a
 871    `symbol-value-buffer-local' object: SYMVAL_OBJECT_FORWARD,
 872    SYMVAL_FIXNUM_FORWARD, SYMVAL_BOOLEAN_FORWARD, and
 873    SYMVAL_UNBOUND_MARKER.  The SYMVAL_CONST_*_FORWARD cannot
 874    be buffer-local because they are unsettable;
 875    SYMVAL_DEFAULT_*_FORWARD cannot be buffer-local because that
 876    makes no sense; making SYMVAL_CURRENT_BUFFER_FORWARD buffer-local
 877    does not have much of an effect (it's already buffer-local); and
 878    SYMVAL_SELECTED_CONSOLE_FORWARD cannot be buffer-local because
 879    that's not currently implemented.
 880
 881
 882    3. symbol-value-varalias
 883
 884    A symbol-value-varalias object is used for variables that
 885    are aliases for other variables.  This object contains
 886    the symbol that this variable is aliased to.
 887    symbol-value-varalias objects cannot occur anywhere within
 888    a symbol-value-buffer-local object, and most of the
 889    low-level functions below do not accept them; you need
 890    to call follow_varalias_pointers to get the actual
 891    symbol to operate on.  */
 892
 893 static Lisp_Object
 894 mark_symbol_value_buffer_local (Lisp_Object obj,
 895                                 void (*markobj) (Lisp_Object))
 896 {
 897   struct symbol_value_buffer_local *bfwd;
 898
 899 #ifdef ERROR_CHECK_TYPECHECK
 900   assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_BUFFER_LOCAL ||
 901           XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_SOME_BUFFER_LOCAL);
 902 #endif
 903
 904   bfwd = XSYMBOL_VALUE_BUFFER_LOCAL (obj);
 905   markobj (bfwd->default_value);
 906   markobj (bfwd->current_value);
 907   markobj (bfwd->current_buffer);
 908   return bfwd->current_alist_element;
 909 }
 910
 911 static Lisp_Object
 912 mark_symbol_value_lisp_magic (Lisp_Object obj,
 913                               void (*markobj) (Lisp_Object))
 914 {
 915   struct symbol_value_lisp_magic *bfwd;
 916   int i;
 917
 918   assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_LISP_MAGIC);
 919
 920   bfwd = XSYMBOL_VALUE_LISP_MAGIC (obj);
 921   for (i = 0; i < MAGIC_HANDLER_MAX; i++)
 922     {
 923       markobj (bfwd->handler[i]);
 924       markobj (bfwd->harg[i]);
 925     }
 926   return bfwd->shadowed;
 927 }
 928
 929 static Lisp_Object
 930 mark_symbol_value_varalias (Lisp_Object obj,
 931                             void (*markobj) (Lisp_Object))
 932 {
 933   struct symbol_value_varalias *bfwd;
 934
 935   assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_VARALIAS);
 936
 937   bfwd = XSYMBOL_VALUE_VARALIAS (obj);
 938   markobj (bfwd->shadowed);
 939   return bfwd->aliasee;
 940 }
 941
 942 /* Should never, ever be called. (except by an external debugger) */
 943 void
 944 print_symbol_value_magic (Lisp_Object obj,
 945                           Lisp_Object printcharfun, int escapeflag)
 946 {
 947   char buf[200];
 948   sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (%s type %d) 0x%lx>",
 949            XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
 950            XSYMBOL_VALUE_MAGIC_TYPE (obj),
 951            (long) XPNTR (obj));
 952   write_c_string (buf, printcharfun);
 953 }
 954
 955 DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-forward",
 956                                symbol_value_forward,
 957                                this_one_is_unmarkable,
 958                                print_symbol_value_magic, 0, 0, 0,
 959                                struct symbol_value_forward);
 960
 961 DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-buffer-local",
 962                                symbol_value_buffer_local,
 963                                mark_symbol_value_buffer_local,
 964                                print_symbol_value_magic, 0, 0, 0,
 965                                struct symbol_value_buffer_local);
 966
 967 DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-lisp-magic",
 968                                symbol_value_lisp_magic,
 969                                mark_symbol_value_lisp_magic,
 970                                print_symbol_value_magic, 0, 0, 0,
 971                                struct symbol_value_lisp_magic);
 972
 973 DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-varalias",
 974                                symbol_value_varalias,
 975                                mark_symbol_value_varalias,
 976                                print_symbol_value_magic, 0, 0, 0,
 977                                struct symbol_value_varalias);
 978
 979 \f
 980 /* Getting and setting values of symbols */
 981
 982 /* Given the raw contents of a symbol value cell, return the Lisp value of
 983    the symbol.  However, VALCONTENTS cannot be a symbol-value-buffer-local,
 984    symbol-value-lisp-magic, or symbol-value-varalias.
 985
 986    BUFFER specifies a buffer, and is used for built-in buffer-local
 987    variables, which are of type SYMVAL_CURRENT_BUFFER_FORWARD.
 988    Note that such variables are never encapsulated in a
 989    symbol-value-buffer-local structure.
 990
 991    CONSOLE specifies a console, and is used for built-in console-local
 992    variables, which are of type SYMVAL_SELECTED_CONSOLE_FORWARD.
 993    Note that such variables are (currently) never encapsulated in a
 994    symbol-value-buffer-local structure.
 995  */
 996
 997 static Lisp_Object
 998 do_symval_forwarding (Lisp_Object valcontents, struct buffer *buffer,
 999                       struct console *console)
1000 {
1001   CONST struct symbol_value_forward *fwd;
1002
1003   if (!SYMBOL_VALUE_MAGIC_P (valcontents))
1004     return valcontents;
1005
1006   fwd = XSYMBOL_VALUE_FORWARD (valcontents);
1007   switch (fwd->magic.type)
1008     {
1009     case SYMVAL_FIXNUM_FORWARD:
1010     case SYMVAL_CONST_FIXNUM_FORWARD:
1011       return make_int (*((int *)symbol_value_forward_forward (fwd)));
1012
1013     case SYMVAL_BOOLEAN_FORWARD:
1014     case SYMVAL_CONST_BOOLEAN_FORWARD:
1015       return *((int *)symbol_value_forward_forward (fwd)) ? Qt : Qnil;
1016
1017     case SYMVAL_OBJECT_FORWARD:
1018     case SYMVAL_CONST_OBJECT_FORWARD:
1019     case SYMVAL_CONST_SPECIFIER_FORWARD:
1020       return *((Lisp_Object *)symbol_value_forward_forward (fwd));
1021
1022     case SYMVAL_DEFAULT_BUFFER_FORWARD:
1023       return (*((Lisp_Object *)((char *) XBUFFER (Vbuffer_defaults)
1024                                 + ((char *)symbol_value_forward_forward (fwd)
1025                                    - (char *)&buffer_local_flags))));
1026
1027
1028     case SYMVAL_CURRENT_BUFFER_FORWARD:
1029     case SYMVAL_CONST_CURRENT_BUFFER_FORWARD:
1030       assert (buffer);
1031       return (*((Lisp_Object *)((char *)buffer
1032                                 + ((char *)symbol_value_forward_forward (fwd)
1033                                    - (char *)&buffer_local_flags))));
1034
1035     case SYMVAL_DEFAULT_CONSOLE_FORWARD:
1036       return (*((Lisp_Object *)((char *) XCONSOLE (Vconsole_defaults)
1037                                 + ((char *)symbol_value_forward_forward (fwd)
1038                                    - (char *)&console_local_flags))));
1039
1040     case SYMVAL_SELECTED_CONSOLE_FORWARD:
1041     case SYMVAL_CONST_SELECTED_CONSOLE_FORWARD:
1042       assert (console);
1043       return (*((Lisp_Object *)((char *)console
1044                                 + ((char *)symbol_value_forward_forward (fwd)
1045                                    - (char *)&console_local_flags))));
1046
1047     case SYMVAL_UNBOUND_MARKER:
1048       return valcontents;
1049
1050     default:
1051       abort ();
1052     }
1053   return Qnil;  /* suppress compiler warning */
1054 }
1055
1056 /* Set the value of default-buffer-local variable SYM to VALUE. */
1057
1058 static void
1059 set_default_buffer_slot_variable (Lisp_Object sym,
1060                                   Lisp_Object value)
1061 {
1062   /* Handle variables like case-fold-search that have special slots in
1063      the buffer. Make them work apparently like buffer_local variables.
1064      */
1065   /* At this point, the value cell may not contain a symbol-value-varalias
1066      or symbol-value-buffer-local, and if there's a handler, we should
1067      have already called it. */
1068   Lisp_Object valcontents = fetch_value_maybe_past_magic (sym, Qt);
1069   CONST struct symbol_value_forward *fwd
1070     = XSYMBOL_VALUE_FORWARD (valcontents);
1071   int offset = ((char *) symbol_value_forward_forward (fwd)
1072                 - (char *) &buffer_local_flags);
1073   int mask = XINT (*((Lisp_Object *) symbol_value_forward_forward (fwd)));
1074   int (*magicfun) (Lisp_Object simm, Lisp_Object *val, Lisp_Object in_object,
1075                    int flags) = symbol_value_forward_magicfun (fwd);
1076
1077   *((Lisp_Object *) (offset + (char *) XBUFFER (Vbuffer_defaults)))
1078     = value;
1079
1080   if (mask > 0)         /* Not always per-buffer */
1081     {
1082       Lisp_Object elt;
1083
1084       /* Set value in each buffer which hasn't shadowed the default */
1085       LIST_LOOP_2 (elt, Vbuffer_alist)
1086         {
1087           struct buffer *b = XBUFFER (XCDR (elt));
1088           if (!(b->local_var_flags & mask))
1089             {
1090               if (magicfun)
1091                 magicfun (sym, &value, make_buffer (b), 0);
1092               *((Lisp_Object *) (offset + (char *) b)) = value;
1093             }
1094         }
1095     }
1096 }
1097
1098 /* Set the value of default-console-local variable SYM to VALUE. */
1099
1100 static void
1101 set_default_console_slot_variable (Lisp_Object sym,
1102                                    Lisp_Object value)
1103 {
1104   /* Handle variables like case-fold-search that have special slots in
1105      the console. Make them work apparently like console_local variables.
1106      */
1107   /* At this point, the value cell may not contain a symbol-value-varalias
1108      or symbol-value-buffer-local, and if there's a handler, we should
1109      have already called it. */
1110   Lisp_Object valcontents = fetch_value_maybe_past_magic (sym, Qt);
1111   CONST struct symbol_value_forward *fwd
1112     = XSYMBOL_VALUE_FORWARD (valcontents);
1113   int offset = ((char *) symbol_value_forward_forward (fwd)
1114                 - (char *) &console_local_flags);
1115   int mask = XINT (*((Lisp_Object *) symbol_value_forward_forward (fwd)));
1116   int (*magicfun) (Lisp_Object simm, Lisp_Object *val, Lisp_Object in_object,
1117                    int flags) = symbol_value_forward_magicfun (fwd);
1118
1119   *((Lisp_Object *) (offset + (char *) XCONSOLE (Vconsole_defaults)))
1120     = value;
1121
1122   if (mask > 0)         /* Not always per-console */
1123     {
1124       Lisp_Object console;
1125
1126       /* Set value in each console which hasn't shadowed the default */
1127       LIST_LOOP_2 (console, Vconsole_list)
1128         {
1129           struct console *d = XCONSOLE (console);
1130           if (!(d->local_var_flags & mask))
1131             {
1132               if (magicfun)
1133                 magicfun (sym, &value, console, 0);
1134               *((Lisp_Object *) (offset + (char *) d)) = value;
1135             }
1136         }
1137     }
1138 }
1139
1140 /* Store NEWVAL into SYM.
1141
1142    SYM's value slot may *not* be types (5) or (6) above,
1143    i.e. no symbol-value-varalias objects. (You should have
1144    forwarded past all of these.)
1145
1146    SYM should not be an unsettable symbol or a symbol with
1147    a magic `set-value' handler (unless you want to explicitly
1148    ignore this handler).
1149
1150    OVALUE is the current value of SYM, but forwarded past any
1151    symbol-value-buffer-local and symbol-value-lisp-magic objects.
1152    (i.e. if SYM is a symbol-value-buffer-local, OVALUE should be
1153    the contents of its current-value cell.) NEWVAL may only be
1154    a simple value or Qunbound.  If SYM is a symbol-value-buffer-local,
1155    this function will only modify its current-value cell, which should
1156    already be set up to point to the current buffer.
1157   */
1158
1159 static void
1160 store_symval_forwarding (Lisp_Object sym, Lisp_Object ovalue,
1161                          Lisp_Object newval)
1162 {
1163   if (!SYMBOL_VALUE_MAGIC_P (ovalue) || UNBOUNDP (ovalue))
1164     {
1165       Lisp_Object *store_pointer = value_slot_past_magic (sym);
1166
1167       if (SYMBOL_VALUE_BUFFER_LOCAL_P (*store_pointer))
1168         store_pointer =
1169           &XSYMBOL_VALUE_BUFFER_LOCAL (*store_pointer)->current_value;
1170
1171       assert (UNBOUNDP (*store_pointer)
1172               || !SYMBOL_VALUE_MAGIC_P (*store_pointer));
1173       *store_pointer = newval;
1174     }
1175   else
1176     {
1177       CONST struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (ovalue);
1178       int (*magicfun) (Lisp_Object simm, Lisp_Object *val,
1179                        Lisp_Object in_object, int flags)
1180         = symbol_value_forward_magicfun (fwd);
1181
1182       switch (XSYMBOL_VALUE_MAGIC_TYPE (ovalue))
1183         {
1184         case SYMVAL_FIXNUM_FORWARD:
1185           CHECK_INT (newval);
1186           if (magicfun)
1187             magicfun (sym, &newval, Qnil, 0);
1188           *((int *) symbol_value_forward_forward (fwd)) = XINT (newval);
1189           return;
1190
1191         case SYMVAL_BOOLEAN_FORWARD:
1192           if (magicfun)
1193             magicfun (sym, &newval, Qnil, 0);
1194           *((int *) symbol_value_forward_forward (fwd))
1195             = ((NILP (newval)) ? 0 : 1);
1196           return;
1197
1198         case SYMVAL_OBJECT_FORWARD:
1199           if (magicfun)
1200             magicfun (sym, &newval, Qnil, 0);
1201           *((Lisp_Object *) symbol_value_forward_forward (fwd)) = newval;
1202           return;
1203
1204         case SYMVAL_DEFAULT_BUFFER_FORWARD:
1205           set_default_buffer_slot_variable (sym, newval);
1206           return;
1207
1208         case SYMVAL_CURRENT_BUFFER_FORWARD:
1209           if (magicfun)
1210             magicfun (sym, &newval, make_buffer (current_buffer), 0);
1211           *((Lisp_Object *) ((char *) current_buffer
1212                              + ((char *) symbol_value_forward_forward (fwd)
1213                                 - (char *) &buffer_local_flags)))
1214             = newval;
1215           return;
1216
1217         case SYMVAL_DEFAULT_CONSOLE_FORWARD:
1218           set_default_console_slot_variable (sym, newval);
1219           return;
1220
1221         case SYMVAL_SELECTED_CONSOLE_FORWARD:
1222           if (magicfun)
1223             magicfun (sym, &newval, Vselected_console, 0);
1224           *((Lisp_Object *) ((char *) XCONSOLE (Vselected_console)
1225                              + ((char *) symbol_value_forward_forward (fwd)
1226                                 - (char *) &console_local_flags)))
1227             = newval;
1228           return;
1229
1230         default:
1231           abort ();
1232         }
1233     }
1234 }
1235
1236 /* Given a per-buffer variable SYMBOL and its raw value-cell contents
1237    BFWD, locate and return a pointer to the element in BUFFER's
1238    local_var_alist for SYMBOL.  The return value will be Qnil if
1239    BUFFER does not have its own value for SYMBOL (i.e. the default
1240    value is seen in that buffer).
1241    */
1242
1243 static Lisp_Object
1244 buffer_local_alist_element (struct buffer *buffer, Lisp_Object symbol,
1245                             struct symbol_value_buffer_local *bfwd)
1246 {
1247   if (!NILP (bfwd->current_buffer) &&
1248       XBUFFER (bfwd->current_buffer) == buffer)
1249     /* This is just an optimization of the below. */
1250     return bfwd->current_alist_element;
1251   else
1252     return assq_no_quit (symbol, buffer->local_var_alist);
1253 }
1254
1255 /* [Remember that the slot that mirrors CURRENT-VALUE in the
1256    symbol-value-buffer-local of a per-buffer variable -- i.e. the
1257    slot in CURRENT-BUFFER's local_var_alist, or the DEFAULT-VALUE
1258    slot -- may be out of date.]
1259
1260    Write out any cached value in buffer-local variable SYMBOL's
1261    buffer-local structure, which is passed in as BFWD.
1262 */
1263
1264 static void
1265 write_out_buffer_local_cache (Lisp_Object symbol,
1266                               struct symbol_value_buffer_local *bfwd)
1267 {
1268   if (!NILP (bfwd->current_buffer))
1269     {
1270       /* We pass 0 for BUFFER because only SYMVAL_CURRENT_BUFFER_FORWARD
1271          uses it, and that type cannot be inside a symbol-value-buffer-local */
1272       Lisp_Object cval = do_symval_forwarding (bfwd->current_value, 0, 0);
1273       if (NILP (bfwd->current_alist_element))
1274         /* current_value may be updated more recently than default_value */
1275         bfwd->default_value = cval;
1276       else
1277         Fsetcdr (bfwd->current_alist_element, cval);
1278     }
1279 }
1280
1281 /* SYM is a buffer-local variable, and BFWD is its buffer-local structure.
1282    Set up BFWD's cache for validity in buffer BUF.  This assumes that
1283    the cache is currently in a consistent state (this can include
1284    not having any value cached, if BFWD->CURRENT_BUFFER is nil).
1285
1286    If the cache is already set up for BUF, this function does nothing
1287    at all.
1288
1289    Otherwise, if SYM forwards out to a C variable, this also forwards
1290    SYM's value in BUF out to the variable.  Therefore, you generally
1291    only want to call this when BUF is, or is about to become, the
1292    current buffer.
1293
1294    (Otherwise, you can just retrieve the value without changing the
1295    cache, at the expense of slower retrieval.)
1296 */
1297
1298 static void
1299 set_up_buffer_local_cache (Lisp_Object sym,
1300                            struct symbol_value_buffer_local *bfwd,
1301                            struct buffer *buf,
1302                            Lisp_Object new_alist_el,
1303                            int set_it_p)
1304 {
1305   Lisp_Object new_val;
1306
1307   if (!NILP (bfwd->current_buffer)
1308       && buf == XBUFFER (bfwd->current_buffer))
1309     /* Cache is already set up. */
1310     return;
1311
1312   /* Flush out the old cache. */
1313   write_out_buffer_local_cache (sym, bfwd);
1314
1315   /* Retrieve the new alist element and new value. */
1316   if (NILP (new_alist_el)
1317       && set_it_p)
1318     new_alist_el = buffer_local_alist_element (buf, sym, bfwd);
1319
1320   if (NILP (new_alist_el))
1321     new_val = bfwd->default_value;
1322   else
1323     new_val = Fcdr (new_alist_el);
1324
1325   bfwd->current_alist_element = new_alist_el;
1326   XSETBUFFER (bfwd->current_buffer, buf);
1327
1328   /* Now store the value into the current-value slot.
1329      We don't simply write it there, because the current-value
1330      slot might be a forwarding pointer, in which case we need
1331      to instead write the value into the C variable.
1332
1333      We might also want to call a magic function.
1334
1335      So instead, we call this function. */
1336   store_symval_forwarding (sym, bfwd->current_value, new_val);
1337 }
1338
1339 \f
1340 void
1341 kill_buffer_local_variables (struct buffer *buf)
1342 {
1343   Lisp_Object prev = Qnil;
1344   Lisp_Object alist;
1345
1346   /* Any which are supposed to be permanent,
1347      make local again, with the same values they had.  */
1348
1349   for (alist = buf->local_var_alist; !NILP (alist); alist = XCDR (alist))
1350     {
1351       Lisp_Object sym = XCAR (XCAR (alist));
1352       struct symbol_value_buffer_local *bfwd;
1353       /* Variables with a symbol-value-varalias should not be here
1354          (we should have forwarded past them) and there must be a
1355          symbol-value-buffer-local.  If there's a symbol-value-lisp-magic,
1356          just forward past it; if the variable has a handler, it was
1357          already called. */
1358       Lisp_Object value = fetch_value_maybe_past_magic (sym, Qt);
1359
1360       assert (SYMBOL_VALUE_BUFFER_LOCAL_P (value));
1361       bfwd = XSYMBOL_VALUE_BUFFER_LOCAL (value);
1362
1363       if (!NILP (Fget (sym, Qpermanent_local, Qnil)))
1364         /* prev points to the last alist element that is still
1365            staying around, so *only* update it now.  This didn't
1366            used to be the case; this bug has been around since
1367            mly's rewrite two years ago! */
1368         prev = alist;
1369       else
1370         {
1371           /* Really truly kill it. */
1372           if (!NILP (prev))
1373             XCDR (prev) = XCDR (alist);
1374           else
1375             buf->local_var_alist = XCDR (alist);
1376
1377           /* We just effectively changed the value for this variable
1378              in BUF. So: */
1379
1380           /* (1) If the cache is caching BUF, invalidate the cache. */
1381           if (!NILP (bfwd->current_buffer) &&
1382               buf == XBUFFER (bfwd->current_buffer))
1383             bfwd->current_buffer = Qnil;
1384
1385           /* (2) If we changed the value in current_buffer and this
1386              variable forwards to a C variable, we need to change the
1387              value of the C variable.  set_up_buffer_local_cache()
1388              will do this.  It doesn't hurt to do it whenever
1389              BUF == current_buffer, so just go ahead and do that. */
1390           if (buf == current_buffer)
1391             set_up_buffer_local_cache (sym, bfwd, buf, Qnil, 0);
1392         }
1393     }
1394 }
1395 \f
1396 static Lisp_Object
1397 find_symbol_value_1 (Lisp_Object sym, struct buffer *buf,
1398                      struct console *con, int swap_it_in,
1399                      Lisp_Object symcons, int set_it_p)
1400 {
1401   Lisp_Object valcontents;
1402
1403  retry:
1404   valcontents = XSYMBOL (sym)->value;
1405
1406  retry_2:
1407   if (!SYMBOL_VALUE_MAGIC_P (valcontents))
1408     return valcontents;
1409
1410   switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
1411     {
1412     case SYMVAL_LISP_MAGIC:
1413       /* #### kludge */
1414       valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
1415       /* semi-change-o */
1416       goto retry_2;
1417
1418     case SYMVAL_VARALIAS:
1419       sym = follow_varalias_pointers (sym, Qt /* #### kludge */);
1420       symcons = Qnil;
1421       /* presto change-o! */
1422       goto retry;
1423
1424     case SYMVAL_BUFFER_LOCAL:
1425     case SYMVAL_SOME_BUFFER_LOCAL:
1426       {
1427         struct symbol_value_buffer_local *bfwd
1428           = XSYMBOL_VALUE_BUFFER_LOCAL (valcontents);
1429
1430         if (swap_it_in)
1431           {
1432             set_up_buffer_local_cache (sym, bfwd, buf, symcons, set_it_p);
1433             valcontents = bfwd->current_value;
1434           }
1435         else
1436           {
1437             if (!NILP (bfwd->current_buffer) &&
1438                 buf == XBUFFER (bfwd->current_buffer))
1439               valcontents = bfwd->current_value;
1440             else if (NILP (symcons))
1441               {
1442                 if (set_it_p)
1443                   valcontents = assq_no_quit (sym, buf->local_var_alist);
1444                 if (NILP (valcontents))
1445                   valcontents = bfwd->default_value;
1446                 else
1447                   valcontents = XCDR (valcontents);
1448               }
1449             else
1450               valcontents = XCDR (symcons);
1451           }
1452         break;
1453       }
1454
1455     default:
1456       break;
1457     }
1458   return do_symval_forwarding (valcontents, buf, con);
1459 }
1460
1461
1462 /* Find the value of a symbol in BUFFER, returning Qunbound if it's not
1463    bound.  Note that it must not be possible to QUIT within this
1464    function. */
1465
1466 Lisp_Object
1467 symbol_value_in_buffer (Lisp_Object sym, Lisp_Object buffer)
1468 {
1469   struct buffer *buf;
1470
1471   CHECK_SYMBOL (sym);
1472
1473   if (NILP (buffer))
1474     buf = current_buffer;
1475   else
1476     {
1477       CHECK_BUFFER (buffer);
1478       buf = XBUFFER (buffer);
1479     }
1480
1481   return find_symbol_value_1 (sym, buf,
1482                               /* If it bombs out at startup due to a
1483                                  Lisp error, this may be nil. */
1484                               CONSOLEP (Vselected_console)
1485                               ? XCONSOLE (Vselected_console) : 0, 0, Qnil, 1);
1486 }
1487
1488 static Lisp_Object
1489 symbol_value_in_console (Lisp_Object sym, Lisp_Object console)
1490 {
1491   CHECK_SYMBOL (sym);
1492
1493   if (NILP (console))
1494     console = Vselected_console;
1495   else
1496     CHECK_CONSOLE (console);
1497
1498   return find_symbol_value_1 (sym, current_buffer, XCONSOLE (console), 0,
1499                               Qnil, 1);
1500 }
1501
1502 /* Return the current value of SYM.  The difference between this function
1503    and calling symbol_value_in_buffer with a BUFFER of Qnil is that
1504    this updates the CURRENT_VALUE slot of buffer-local variables to
1505    point to the current buffer, while symbol_value_in_buffer doesn't. */
1506
1507 Lisp_Object
1508 find_symbol_value (Lisp_Object sym)
1509 {
1510   /* WARNING: This function can be called when current_buffer is 0
1511      and Vselected_console is Qnil, early in initialization. */
1512   struct console *con;
1513   Lisp_Object valcontents;
1514
1515   CHECK_SYMBOL (sym);
1516
1517   valcontents = XSYMBOL (sym)->value;
1518   if (!SYMBOL_VALUE_MAGIC_P (valcontents))
1519     return valcontents;
1520
1521   if (CONSOLEP (Vselected_console))
1522     con = XCONSOLE (Vselected_console);
1523   else
1524     {
1525       /* This can also get called while we're preparing to shutdown.
1526          #### What should really happen in that case?  Should we
1527          actually fix things so we can't get here in that case? */
1528       assert (!initialized || preparing_for_armageddon);
1529       con = 0;
1530     }
1531
1532   return find_symbol_value_1 (sym, current_buffer, con, 1, Qnil, 1);
1533 }
1534
1535 /* This is an optimized function for quick lookup of buffer local symbols
1536    by avoiding O(n) search.  This will work when either:
1537      a) We have already found the symbol e.g. by traversing local_var_alist.
1538    or
1539      b) We know that the symbol will not be found in the current buffer's
1540         list of local variables.
1541    In the former case, find_it_p is 1 and symbol_cons is the element from
1542    local_var_alist.  In the latter case, find_it_p is 0 and symbol_cons
1543    is the symbol.
1544
1545    This function is called from set_buffer_internal which does both of these
1546    things. */
1547
1548 Lisp_Object
1549 find_symbol_value_quickly (Lisp_Object symbol_cons, int find_it_p)
1550 {
1551   /* WARNING: This function can be called when current_buffer is 0
1552      and Vselected_console is Qnil, early in initialization. */
1553   struct console *con;
1554   Lisp_Object sym = find_it_p ? XCAR (symbol_cons) : symbol_cons;
1555
1556   CHECK_SYMBOL (sym);
1557   if (CONSOLEP (Vselected_console))
1558     con = XCONSOLE (Vselected_console);
1559   else
1560     {
1561       /* This can also get called while we're preparing to shutdown.
1562          #### What should really happen in that case?  Should we
1563          actually fix things so we can't get here in that case? */
1564       assert (!initialized || preparing_for_armageddon);
1565       con = 0;
1566     }
1567
1568   return find_symbol_value_1 (sym, current_buffer, con, 1,
1569                               find_it_p ? symbol_cons : Qnil,
1570                               find_it_p);
1571 }
1572
1573 DEFUN ("symbol-value", Fsymbol_value, 1, 1, 0, /*
1574 Return SYMBOL's value.  Error if that is void.
1575 */
1576        (symbol))
1577 {
1578   Lisp_Object val = find_symbol_value (symbol);
1579
1580   if (UNBOUNDP (val))
1581     return Fsignal (Qvoid_variable, list1 (symbol));
1582   else
1583     return val;
1584 }
1585
1586 DEFUN ("set", Fset, 2, 2, 0, /*
1587 Set SYMBOL's value to NEWVAL, and return NEWVAL.
1588 */
1589        (symbol, newval))
1590 {
1591   REGISTER Lisp_Object valcontents;
1592   struct Lisp_Symbol *sym;
1593   /* remember, we're called by Fmakunbound() as well */
1594
1595   CHECK_SYMBOL (symbol);
1596
1597  retry:
1598   sym = XSYMBOL (symbol);
1599   valcontents = sym->value;
1600
1601   if (EQ (symbol, Qnil) ||
1602       EQ (symbol, Qt)   ||
1603       SYMBOL_IS_KEYWORD (symbol))
1604     reject_constant_symbols (symbol, newval, 0,
1605                              UNBOUNDP (newval) ? Qmakunbound : Qset);
1606
1607   if (!SYMBOL_VALUE_MAGIC_P (valcontents) || UNBOUNDP (valcontents))
1608     {
1609       sym->value = newval;
1610       return newval;
1611     }
1612
1613   reject_constant_symbols (symbol, newval, 0,
1614                            UNBOUNDP (newval) ? Qmakunbound : Qset);
1615
1616  retry_2:
1617
1618   switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
1619     {
1620     case SYMVAL_LISP_MAGIC:
1621       {
1622         Lisp_Object retval;
1623
1624         if (UNBOUNDP (newval))
1625           retval = maybe_call_magic_handler (symbol, Qmakunbound, 0);
1626         else
1627           retval = maybe_call_magic_handler (symbol, Qset, 1, newval);
1628         if (!UNBOUNDP (retval))
1629           return newval;
1630         valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
1631         /* semi-change-o */
1632         goto retry_2;
1633       }
1634
1635     case SYMVAL_VARALIAS:
1636       symbol = follow_varalias_pointers (symbol,
1637                                          UNBOUNDP (newval)
1638                                          ? Qmakunbound : Qset);
1639       /* presto change-o! */
1640       goto retry;
1641
1642     case SYMVAL_FIXNUM_FORWARD:
1643     case SYMVAL_BOOLEAN_FORWARD:
1644     case SYMVAL_OBJECT_FORWARD:
1645     case SYMVAL_DEFAULT_BUFFER_FORWARD:
1646     case SYMVAL_DEFAULT_CONSOLE_FORWARD:
1647       if (UNBOUNDP (newval))
1648         signal_error (Qerror,
1649                       list2 (build_string ("Cannot makunbound"), symbol));
1650       break;
1651
1652       /* case SYMVAL_UNBOUND_MARKER: break; */
1653
1654     case SYMVAL_CURRENT_BUFFER_FORWARD:
1655       {
1656         CONST struct symbol_value_forward *fwd
1657           = XSYMBOL_VALUE_FORWARD (valcontents);
1658         int mask = XINT (*((Lisp_Object *)
1659                            symbol_value_forward_forward (fwd)));
1660         if (mask > 0)
1661           /* Setting this variable makes it buffer-local */
1662           current_buffer->local_var_flags |= mask;
1663         break;
1664       }
1665
1666     case SYMVAL_SELECTED_CONSOLE_FORWARD:
1667       {
1668         CONST struct symbol_value_forward *fwd
1669           = XSYMBOL_VALUE_FORWARD (valcontents);
1670         int mask = XINT (*((Lisp_Object *)
1671                            symbol_value_forward_forward (fwd)));
1672         if (mask > 0)
1673           /* Setting this variable makes it console-local */
1674           XCONSOLE (Vselected_console)->local_var_flags |= mask;
1675         break;
1676       }
1677
1678     case SYMVAL_BUFFER_LOCAL:
1679     case SYMVAL_SOME_BUFFER_LOCAL:
1680       {
1681         /* If we want to examine or set the value and
1682            CURRENT-BUFFER is current, we just examine or set
1683            CURRENT-VALUE. If CURRENT-BUFFER is not current, we
1684            store the current CURRENT-VALUE value into
1685            CURRENT-ALIST- ELEMENT, then find the appropriate alist
1686            element for the buffer now current and set up
1687            CURRENT-ALIST-ELEMENT.  Then we set CURRENT-VALUE out
1688            of that element, and store into CURRENT-BUFFER.
1689
1690            If we are setting the variable and the current buffer does
1691            not have an alist entry for this variable, an alist entry is
1692            created.
1693
1694            Note that CURRENT-VALUE can be a forwarding pointer.
1695            Each time it is examined or set, forwarding must be
1696            done. */
1697         struct symbol_value_buffer_local *bfwd
1698           = XSYMBOL_VALUE_BUFFER_LOCAL (valcontents);
1699         int some_buffer_local_p =
1700           (bfwd->magic.type == SYMVAL_SOME_BUFFER_LOCAL);
1701         /* What value are we caching right now?  */
1702         Lisp_Object aelt = bfwd->current_alist_element;
1703
1704         if (!NILP (bfwd->current_buffer) &&
1705             current_buffer == XBUFFER (bfwd->current_buffer)
1706             && ((some_buffer_local_p)
1707                 ? 1                /* doesn't automatically become local */
1708                 : !NILP (aelt) /* already local */
1709                 ))
1710           {
1711             /* Cache is valid */
1712             valcontents = bfwd->current_value;
1713           }
1714         else
1715           {
1716             /* If the current buffer is not the buffer whose binding is
1717                currently cached, or if it's a SYMVAL_BUFFER_LOCAL and
1718                we're looking at the default value, the cache is invalid; we
1719                need to write it out, and find the new CURRENT-ALIST-ELEMENT
1720             */
1721
1722             /* Write out the cached value for the old buffer; copy it
1723                back to its alist element.  This works if the current
1724                buffer only sees the default value, too.  */
1725             write_out_buffer_local_cache (symbol, bfwd);
1726
1727             /* Find the new value for CURRENT-ALIST-ELEMENT.  */
1728             aelt = buffer_local_alist_element (current_buffer, symbol, bfwd);
1729             if (NILP (aelt))
1730               {
1731                 /* This buffer is still seeing the default value.  */
1732                 if (!some_buffer_local_p)
1733                   {
1734                     /* If it's a SYMVAL_BUFFER_LOCAL, give this buffer a
1735                        new assoc for a local value and set
1736                        CURRENT-ALIST-ELEMENT to point to that.  */
1737                     aelt =
1738                       do_symval_forwarding (bfwd->current_value,
1739                                             current_buffer,
1740                                             XCONSOLE (Vselected_console));
1741                     aelt = Fcons (symbol, aelt);
1742                     current_buffer->local_var_alist
1743                       = Fcons (aelt, current_buffer->local_var_alist);
1744                   }
1745                 else
1746                   {
1747                     /* If the variable is a SYMVAL_SOME_BUFFER_LOCAL,
1748                        we're currently seeing the default value. */
1749                     ;
1750                   }
1751               }
1752             /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT.  */
1753             bfwd->current_alist_element = aelt;
1754             /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate.  */
1755             XSETBUFFER (bfwd->current_buffer, current_buffer);
1756             valcontents = bfwd->current_value;
1757           }
1758         break;
1759       }
1760     default:
1761       abort ();
1762     }
1763   store_symval_forwarding (symbol, valcontents, newval);
1764
1765   return newval;
1766 }
1767
1768 \f
1769 /* Access or set a buffer-local symbol's default value.  */
1770
1771 /* Return the default value of SYM, but don't check for voidness.
1772    Return Qunbound if it is void.  */
1773
1774 static Lisp_Object
1775 default_value (Lisp_Object sym)
1776 {
1777   Lisp_Object valcontents;
1778
1779   CHECK_SYMBOL (sym);
1780
1781  retry:
1782   valcontents = XSYMBOL (sym)->value;
1783
1784  retry_2:
1785   if (!SYMBOL_VALUE_MAGIC_P (valcontents))
1786     return valcontents;
1787
1788   switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
1789     {
1790     case SYMVAL_LISP_MAGIC:
1791       /* #### kludge */
1792       valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
1793       /* semi-change-o */
1794       goto retry_2;
1795
1796     case SYMVAL_VARALIAS:
1797       sym = follow_varalias_pointers (sym, Qt /* #### kludge */);
1798       /* presto change-o! */
1799       goto retry;
1800
1801     case SYMVAL_UNBOUND_MARKER:
1802       return valcontents;
1803
1804     case SYMVAL_CURRENT_BUFFER_FORWARD:
1805       {
1806         CONST struct symbol_value_forward *fwd
1807           = XSYMBOL_VALUE_FORWARD (valcontents);
1808         return (*((Lisp_Object *)((char *) XBUFFER (Vbuffer_defaults)
1809                                   + ((char *)symbol_value_forward_forward (fwd)
1810                                      - (char *)&buffer_local_flags))));
1811       }
1812
1813     case SYMVAL_SELECTED_CONSOLE_FORWARD:
1814       {
1815         CONST struct symbol_value_forward *fwd
1816           = XSYMBOL_VALUE_FORWARD (valcontents);
1817         return (*((Lisp_Object *)((char *) XCONSOLE (Vconsole_defaults)
1818                                   + ((char *)symbol_value_forward_forward (fwd)
1819                                      - (char *)&console_local_flags))));
1820       }
1821
1822     case SYMVAL_BUFFER_LOCAL:
1823     case SYMVAL_SOME_BUFFER_LOCAL:
1824       {
1825         struct symbol_value_buffer_local *bfwd =
1826           XSYMBOL_VALUE_BUFFER_LOCAL (valcontents);
1827
1828         /* Handle user-created local variables.  */
1829         /* If var is set up for a buffer that lacks a local value for it,
1830            the current value is nominally the default value.
1831            But the current value slot may be more up to date, since
1832            ordinary setq stores just that slot.  So use that.  */
1833         if (NILP (bfwd->current_alist_element))
1834           return do_symval_forwarding (bfwd->current_value, current_buffer,
1835                                        XCONSOLE (Vselected_console));
1836         else
1837           return bfwd->default_value;
1838       }
1839     default:
1840       /* For other variables, get the current value.    */
1841       return do_symval_forwarding (valcontents, current_buffer,
1842                                    XCONSOLE (Vselected_console));
1843     }
1844
1845   RETURN_NOT_REACHED (Qnil)     /* suppress compiler warning */
1846 }
1847
1848 DEFUN ("default-boundp", Fdefault_boundp, 1, 1, 0, /*
1849 Return t if SYMBOL has a non-void default value.
1850 This is the value that is seen in buffers that do not have their own values
1851 for this variable.
1852 */
1853        (symbol))
1854 {
1855   return UNBOUNDP (default_value (symbol)) ? Qnil : Qt;
1856 }
1857
1858 DEFUN ("default-value", Fdefault_value, 1, 1, 0, /*
1859 Return SYMBOL's default value.
1860 This is the value that is seen in buffers that do not have their own values
1861 for this variable.  The default value is meaningful for variables with
1862 local bindings in certain buffers.
1863 */
1864        (symbol))
1865 {
1866   Lisp_Object value = default_value (symbol);
1867
1868   return UNBOUNDP (value) ? Fsignal (Qvoid_variable, list1 (symbol)) : value;
1869 }
1870
1871 DEFUN ("set-default", Fset_default, 2, 2, 0, /*
1872 Set SYMBOL's default value to VAL.  SYMBOL and VAL are evaluated.
1873 The default value is seen in buffers that do not have their own values
1874 for this variable.
1875 */
1876        (symbol, value))
1877 {
1878   Lisp_Object valcontents;
1879
1880   CHECK_SYMBOL (symbol);
1881
1882  retry:
1883   valcontents = XSYMBOL (symbol)->value;
1884
1885  retry_2:
1886   if (!SYMBOL_VALUE_MAGIC_P (valcontents))
1887     return Fset (symbol, value);
1888
1889   switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
1890     {
1891     case SYMVAL_LISP_MAGIC:
1892       RETURN_IF_NOT_UNBOUND (maybe_call_magic_handler (symbol, Qset_default, 1,
1893                                                        value));
1894       valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
1895       /* semi-change-o */
1896       goto retry_2;
1897
1898     case SYMVAL_VARALIAS:
1899       symbol = follow_varalias_pointers (symbol, Qset_default);
1900       /* presto change-o! */
1901       goto retry;
1902
1903     case SYMVAL_CURRENT_BUFFER_FORWARD:
1904       set_default_buffer_slot_variable (symbol, value);
1905       return value;
1906
1907     case SYMVAL_SELECTED_CONSOLE_FORWARD:
1908       set_default_console_slot_variable (symbol, value);
1909       return value;
1910
1911     case SYMVAL_BUFFER_LOCAL:
1912     case SYMVAL_SOME_BUFFER_LOCAL:
1913       {
1914         /* Store new value into the DEFAULT-VALUE slot */
1915         struct symbol_value_buffer_local *bfwd
1916           = XSYMBOL_VALUE_BUFFER_LOCAL (valcontents);
1917
1918         bfwd->default_value = value;
1919         /* If current-buffer doesn't shadow default_value,
1920          *  we must set the CURRENT-VALUE slot too */
1921         if (NILP (bfwd->current_alist_element))
1922           store_symval_forwarding (symbol, bfwd->current_value, value);
1923         return value;
1924       }
1925
1926     default:
1927       return Fset (symbol, value);
1928     }
1929 }
1930
1931 DEFUN ("setq-default", Fsetq_default, 0, UNEVALLED, 0, /*
1932 Set the default value of variable SYMBOL to VALUE.
1933 SYMBOL, the variable name, is literal (not evaluated);
1934 VALUE is an expression and it is evaluated.
1935 The default value of a variable is seen in buffers
1936 that do not have their own values for the variable.
1937
1938 More generally, you can use multiple variables and values, as in
1939   (setq-default SYMBOL VALUE SYMBOL VALUE...)
1940 This sets each SYMBOL's default value to the corresponding VALUE.
1941 The VALUE for the Nth SYMBOL can refer to the new default values
1942 of previous SYMBOLs.
1943 */
1944        (args))
1945 {
1946   /* This function can GC */
1947   Lisp_Object symbol, tail, val = Qnil;
1948   int nargs;
1949   struct gcpro gcpro1;
1950
1951   GET_LIST_LENGTH (args, nargs);
1952
1953   if (nargs & 1)                /* Odd number of arguments? */
1954     Fsignal (Qwrong_number_of_arguments,
1955              list2 (Qsetq_default, make_int (nargs)));
1956
1957   GCPRO1 (val);
1958
1959   PROPERTY_LIST_LOOP (tail, symbol, val, args)
1960     {
1961       val = Feval (val);
1962       Fset_default (symbol, val);
1963     }
1964
1965   UNGCPRO;
1966   return val;
1967 }
1968 \f
1969 /* Lisp functions for creating and removing buffer-local variables.  */
1970
1971 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, 1, 1,
1972        "vMake Variable Buffer Local: ", /*
1973 Make VARIABLE have a separate value for each buffer.
1974 At any time, the value for the current buffer is in effect.
1975 There is also a default value which is seen in any buffer which has not yet
1976 set its own value.
1977 Using `set' or `setq' to set the variable causes it to have a separate value
1978 for the current buffer if it was previously using the default value.
1979 The function `default-value' gets the default value and `set-default'
1980 sets it.
1981 */
1982        (variable))
1983 {
1984   Lisp_Object valcontents;
1985
1986   CHECK_SYMBOL (variable);
1987
1988  retry:
1989   verify_ok_for_buffer_local (variable, Qmake_variable_buffer_local);
1990
1991   valcontents = XSYMBOL (variable)->value;
1992
1993  retry_2:
1994   if (SYMBOL_VALUE_MAGIC_P (valcontents))
1995     {
1996       switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
1997         {
1998         case SYMVAL_LISP_MAGIC:
1999           if (!UNBOUNDP (maybe_call_magic_handler
2000                          (variable, Qmake_variable_buffer_local, 0)))
2001             return variable;
2002           valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
2003           /* semi-change-o */
2004           goto retry_2;
2005
2006         case SYMVAL_VARALIAS:
2007           variable = follow_varalias_pointers (variable,
2008                                                Qmake_variable_buffer_local);
2009           /* presto change-o! */
2010           goto retry;
2011
2012         case SYMVAL_FIXNUM_FORWARD:
2013         case SYMVAL_BOOLEAN_FORWARD:
2014         case SYMVAL_OBJECT_FORWARD:
2015         case SYMVAL_UNBOUND_MARKER:
2016           break;
2017
2018         case SYMVAL_CURRENT_BUFFER_FORWARD:
2019         case SYMVAL_BUFFER_LOCAL:
2020           /* Already per-each-buffer */
2021           return variable;
2022
2023         case SYMVAL_SOME_BUFFER_LOCAL:
2024           /* Transmogrify */
2025           XSYMBOL_VALUE_BUFFER_LOCAL (valcontents)->magic.type =
2026             SYMVAL_BUFFER_LOCAL;
2027           return variable;
2028
2029         default:
2030           abort ();
2031         }
2032     }
2033
2034   {
2035     struct symbol_value_buffer_local *bfwd
2036       = alloc_lcrecord_type (struct symbol_value_buffer_local,
2037                              &lrecord_symbol_value_buffer_local);
2038     Lisp_Object foo;
2039     bfwd->magic.type = SYMVAL_BUFFER_LOCAL;
2040
2041     bfwd->default_value = find_symbol_value (variable);
2042     bfwd->current_value = valcontents;
2043     bfwd->current_alist_element = Qnil;
2044     bfwd->current_buffer = Fcurrent_buffer ();
2045     XSETSYMBOL_VALUE_MAGIC (foo, bfwd);
2046     *value_slot_past_magic (variable) = foo;
2047 #if 1                           /* #### Yuck!   FSFmacs bug-compatibility*/
2048     /* This sets the default-value of any make-variable-buffer-local to nil.
2049        That just sucks.  User can just use setq-default to effect that,
2050        but there's no way to do makunbound-default to undo this lossage. */
2051     if (UNBOUNDP (valcontents))
2052       bfwd->default_value = Qnil;
2053 #endif
2054 #if 0                           /* #### Yuck! */
2055     /* This sets the value to nil in this buffer.
2056        User could use (setq variable nil) to do this.
2057        It isn't as egregious to do this automatically
2058        as it is to do so to the default-value, but it's
2059        still really dubious. */
2060     if (UNBOUNDP (valcontents))
2061       Fset (variable, Qnil);
2062 #endif
2063     return variable;
2064   }
2065 }
2066
2067 DEFUN ("make-local-variable", Fmake_local_variable, 1, 1,
2068        "vMake Local Variable: ", /*
2069 Make VARIABLE have a separate value in the current buffer.
2070 Other buffers will continue to share a common default value.
2071 \(The buffer-local value of VARIABLE starts out as the same value
2072 VARIABLE previously had.  If VARIABLE was void, it remains void.)
2073 See also `make-variable-buffer-local'.
2074
2075 If the variable is already arranged to become local when set,
2076 this function causes a local value to exist for this buffer,
2077 just as setting the variable would do.
2078
2079 Do not use `make-local-variable' to make a hook variable buffer-local.
2080 Use `make-local-hook' instead.
2081 */
2082        (variable))
2083 {
2084   Lisp_Object valcontents;
2085   struct symbol_value_buffer_local *bfwd;
2086
2087   CHECK_SYMBOL (variable);
2088
2089  retry:
2090   verify_ok_for_buffer_local (variable, Qmake_local_variable);
2091
2092   valcontents = XSYMBOL (variable)->value;
2093
2094  retry_2:
2095   if (SYMBOL_VALUE_MAGIC_P (valcontents))
2096     {
2097       switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
2098         {
2099         case SYMVAL_LISP_MAGIC:
2100           if (!UNBOUNDP (maybe_call_magic_handler
2101                          (variable, Qmake_local_variable, 0)))
2102             return variable;
2103           valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
2104           /* semi-change-o */
2105           goto retry_2;
2106
2107         case SYMVAL_VARALIAS:
2108           variable = follow_varalias_pointers (variable, Qmake_local_variable);
2109           /* presto change-o! */
2110           goto retry;
2111
2112         case SYMVAL_FIXNUM_FORWARD:
2113         case SYMVAL_BOOLEAN_FORWARD:
2114         case SYMVAL_OBJECT_FORWARD:
2115         case SYMVAL_UNBOUND_MARKER:
2116           break;
2117
2118         case SYMVAL_BUFFER_LOCAL:
2119         case SYMVAL_CURRENT_BUFFER_FORWARD:
2120           {
2121             /* Make sure the symbol has a local value in this particular
2122                buffer, by setting it to the same value it already has.  */
2123             Fset (variable, find_symbol_value (variable));
2124             return variable;
2125           }
2126
2127         case SYMVAL_SOME_BUFFER_LOCAL:
2128           {
2129             if (!NILP (buffer_local_alist_element (current_buffer,
2130                                                    variable,
2131                                                    (XSYMBOL_VALUE_BUFFER_LOCAL
2132                                                     (valcontents)))))
2133               goto already_local_to_current_buffer;
2134             else
2135               goto already_local_to_some_other_buffer;
2136           }
2137
2138         default:
2139           abort ();
2140         }
2141     }
2142
2143   /* Make sure variable is set up to hold per-buffer values */
2144   bfwd = alloc_lcrecord_type (struct symbol_value_buffer_local,
2145                               &lrecord_symbol_value_buffer_local);
2146   bfwd->magic.type = SYMVAL_SOME_BUFFER_LOCAL;
2147
2148   bfwd->current_buffer = Qnil;
2149   bfwd->current_alist_element = Qnil;
2150   bfwd->current_value = valcontents;
2151   /* passing 0 is OK because this should never be a
2152      SYMVAL_CURRENT_BUFFER_FORWARD or SYMVAL_SELECTED_CONSOLE_FORWARD
2153      variable. */
2154   bfwd->default_value = do_symval_forwarding (valcontents, 0, 0);
2155
2156 #if 0
2157   if (UNBOUNDP (bfwd->default_value))
2158     bfwd->default_value = Qnil; /* Yuck! */
2159 #endif
2160
2161   XSETSYMBOL_VALUE_MAGIC (valcontents, bfwd);
2162   *value_slot_past_magic (variable) = valcontents;
2163
2164  already_local_to_some_other_buffer:
2165
2166   /* Make sure this buffer has its own value of variable */
2167   bfwd = XSYMBOL_VALUE_BUFFER_LOCAL (valcontents);
2168
2169   if (UNBOUNDP (bfwd->default_value))
2170     {
2171       /* If default value is unbound, set local value to nil. */
2172       XSETBUFFER (bfwd->current_buffer, current_buffer);
2173       bfwd->current_alist_element = Fcons (variable, Qnil);
2174       current_buffer->local_var_alist =
2175         Fcons (bfwd->current_alist_element, current_buffer->local_var_alist);
2176       store_symval_forwarding (variable, bfwd->current_value, Qnil);
2177       return variable;
2178     }
2179
2180   current_buffer->local_var_alist
2181     = Fcons (Fcons (variable, bfwd->default_value),
2182              current_buffer->local_var_alist);
2183
2184   /* Make sure symbol does not think it is set up for this buffer;
2185      force it to look once again for this buffer's value */
2186   if (!NILP (bfwd->current_buffer) &&
2187       current_buffer == XBUFFER (bfwd->current_buffer))
2188     bfwd->current_buffer = Qnil;
2189
2190  already_local_to_current_buffer:
2191
2192   /* If the symbol forwards into a C variable, then swap in the
2193      variable for this buffer immediately.  If C code modifies the
2194      variable before we swap in, then that new value will clobber the
2195      default value the next time we swap.  */
2196   bfwd = XSYMBOL_VALUE_BUFFER_LOCAL (valcontents);
2197   if (SYMBOL_VALUE_MAGIC_P (bfwd->current_value))
2198     {
2199       switch (XSYMBOL_VALUE_MAGIC_TYPE (bfwd->current_value))
2200         {
2201         case SYMVAL_FIXNUM_FORWARD:
2202         case SYMVAL_BOOLEAN_FORWARD:
2203         case SYMVAL_OBJECT_FORWARD:
2204         case SYMVAL_DEFAULT_BUFFER_FORWARD:
2205           set_up_buffer_local_cache (variable, bfwd, current_buffer, Qnil, 1);
2206           break;
2207
2208         case SYMVAL_UNBOUND_MARKER:
2209         case SYMVAL_CURRENT_BUFFER_FORWARD:
2210           break;
2211
2212         default:
2213           abort ();
2214         }
2215     }
2216
2217   return variable;
2218 }
2219
2220 DEFUN ("kill-local-variable", Fkill_local_variable, 1, 1,
2221        "vKill Local Variable: ", /*
2222 Make VARIABLE no longer have a separate value in the current buffer.
2223 From now on the default value will apply in this buffer.
2224 */
2225        (variable))
2226 {
2227   Lisp_Object valcontents;
2228
2229   CHECK_SYMBOL (variable);
2230
2231  retry:
2232   valcontents = XSYMBOL (variable)->value;
2233
2234  retry_2:
2235   if (!SYMBOL_VALUE_MAGIC_P (valcontents))
2236     return variable;
2237
2238   switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
2239     {
2240     case SYMVAL_LISP_MAGIC:
2241       if (!UNBOUNDP (maybe_call_magic_handler
2242                      (variable, Qkill_local_variable, 0)))
2243         return variable;
2244       valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
2245       /* semi-change-o */
2246       goto retry_2;
2247
2248     case SYMVAL_VARALIAS:
2249       variable = follow_varalias_pointers (variable, Qkill_local_variable);
2250       /* presto change-o! */
2251       goto retry;
2252
2253     case SYMVAL_CURRENT_BUFFER_FORWARD:
2254       {
2255         CONST struct symbol_value_forward *fwd
2256           = XSYMBOL_VALUE_FORWARD (valcontents);
2257         int offset = ((char *) symbol_value_forward_forward (fwd)
2258                                - (char *) &buffer_local_flags);
2259         int mask =
2260           XINT (*((Lisp_Object *) symbol_value_forward_forward (fwd)));
2261
2262         if (mask > 0)
2263           {
2264             int (*magicfun) (Lisp_Object sym, Lisp_Object *val,
2265                              Lisp_Object in_object, int flags) =
2266                                symbol_value_forward_magicfun (fwd);
2267             Lisp_Object oldval = * (Lisp_Object *)
2268               (offset + (char *) XBUFFER (Vbuffer_defaults));
2269             if (magicfun)
2270               (magicfun) (variable, &oldval, make_buffer (current_buffer), 0);
2271             *(Lisp_Object *) (offset + (char *) current_buffer)
2272               = oldval;
2273             current_buffer->local_var_flags &= ~mask;
2274           }
2275         return variable;
2276       }
2277
2278     case SYMVAL_BUFFER_LOCAL:
2279     case SYMVAL_SOME_BUFFER_LOCAL:
2280       {
2281         /* Get rid of this buffer's alist element, if any */
2282         struct symbol_value_buffer_local *bfwd
2283           = XSYMBOL_VALUE_BUFFER_LOCAL (valcontents);
2284         Lisp_Object alist = current_buffer->local_var_alist;
2285         Lisp_Object alist_element
2286           = buffer_local_alist_element (current_buffer, variable, bfwd);
2287
2288         if (!NILP (alist_element))
2289           current_buffer->local_var_alist = Fdelq (alist_element, alist);
2290
2291         /* Make sure symbol does not think it is set up for this buffer;
2292            force it to look once again for this buffer's value */
2293         if (!NILP (bfwd->current_buffer) &&
2294             current_buffer == XBUFFER (bfwd->current_buffer))
2295           bfwd->current_buffer = Qnil;
2296
2297         /* We just changed the value in the current_buffer.  If this
2298            variable forwards to a C variable, we need to change the
2299            value of the C variable.  set_up_buffer_local_cache()
2300            will do this.  It doesn't hurt to do it always,
2301            so just go ahead and do that. */
2302         set_up_buffer_local_cache (variable, bfwd, current_buffer, Qnil, 1);
2303       }
2304       return variable;
2305
2306     default:
2307       return variable;
2308     }
2309   RETURN_NOT_REACHED(Qnil)      /* suppress compiler warning */
2310 }
2311
2312
2313 DEFUN ("kill-console-local-variable", Fkill_console_local_variable, 1, 1,
2314        "vKill Console Local Variable: ", /*
2315 Make VARIABLE no longer have a separate value in the selected console.
2316 From now on the default value will apply in this console.
2317 */
2318        (variable))
2319 {
2320   Lisp_Object valcontents;
2321
2322   CHECK_SYMBOL (variable);
2323
2324  retry:
2325   valcontents = XSYMBOL (variable)->value;
2326
2327  retry_2:
2328   if (!SYMBOL_VALUE_MAGIC_P (valcontents))
2329     return variable;
2330
2331   switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
2332     {
2333     case SYMVAL_LISP_MAGIC:
2334       if (!UNBOUNDP (maybe_call_magic_handler
2335                      (variable, Qkill_console_local_variable, 0)))
2336         return variable;
2337       valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
2338       /* semi-change-o */
2339       goto retry_2;
2340
2341     case SYMVAL_VARALIAS:
2342       variable = follow_varalias_pointers (variable,
2343                                            Qkill_console_local_variable);
2344       /* presto change-o! */
2345       goto retry;
2346
2347     case SYMVAL_SELECTED_CONSOLE_FORWARD:
2348       {
2349         CONST struct symbol_value_forward *fwd
2350           = XSYMBOL_VALUE_FORWARD (valcontents);
2351         int offset = ((char *) symbol_value_forward_forward (fwd)
2352                                - (char *) &console_local_flags);
2353         int mask =
2354           XINT (*((Lisp_Object *) symbol_value_forward_forward (fwd)));
2355
2356         if (mask > 0)
2357           {
2358             int (*magicfun) (Lisp_Object sym, Lisp_Object *val,
2359                              Lisp_Object in_object, int flags) =
2360                                symbol_value_forward_magicfun (fwd);
2361             Lisp_Object oldval = * (Lisp_Object *)
2362               (offset + (char *) XCONSOLE (Vconsole_defaults));
2363             if (magicfun)
2364               magicfun (variable, &oldval, Vselected_console, 0);
2365             *(Lisp_Object *) (offset + (char *) XCONSOLE (Vselected_console))
2366               = oldval;
2367             XCONSOLE (Vselected_console)->local_var_flags &= ~mask;
2368           }
2369         return variable;
2370       }
2371
2372     default:
2373       return variable;
2374     }
2375 }
2376
2377 /* Used by specbind to determine what effects it might have.  Returns:
2378  *   0 if symbol isn't buffer-local, and wouldn't be after it is set
2379  *  <0 if symbol isn't presently buffer-local, but set would make it so
2380  *  >0 if symbol is presently buffer-local
2381  */
2382 int
2383 symbol_value_buffer_local_info (Lisp_Object symbol, struct buffer *buffer)
2384 {
2385   Lisp_Object valcontents;
2386
2387  retry:
2388   valcontents = XSYMBOL (symbol)->value;
2389
2390  retry_2:
2391   if (SYMBOL_VALUE_MAGIC_P (valcontents))
2392     {
2393       switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
2394         {
2395         case SYMVAL_LISP_MAGIC:
2396           /* #### kludge */
2397           valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
2398           /* semi-change-o */
2399           goto retry_2;
2400
2401         case SYMVAL_VARALIAS:
2402           symbol = follow_varalias_pointers (symbol, Qt /* #### kludge */);
2403           /* presto change-o! */
2404           goto retry;
2405
2406         case SYMVAL_CURRENT_BUFFER_FORWARD:
2407           {
2408             CONST struct symbol_value_forward *fwd
2409               = XSYMBOL_VALUE_FORWARD (valcontents);
2410             int mask = XINT (*((Lisp_Object *)
2411                                symbol_value_forward_forward (fwd)));
2412             if ((mask <= 0) || (buffer && (buffer->local_var_flags & mask)))
2413               /* Already buffer-local */
2414               return 1;
2415             else
2416               /* Would be buffer-local after set */
2417               return -1;
2418           }
2419         case SYMVAL_BUFFER_LOCAL:
2420         case SYMVAL_SOME_BUFFER_LOCAL:
2421           {
2422             struct symbol_value_buffer_local *bfwd
2423               = XSYMBOL_VALUE_BUFFER_LOCAL (valcontents);
2424             if (buffer
2425                 && !NILP (buffer_local_alist_element (buffer, symbol, bfwd)))
2426               return 1;
2427             else
2428               /* Automatically becomes local when set */
2429               return bfwd->magic.type == SYMVAL_BUFFER_LOCAL ? -1 : 0;
2430           }
2431         default:
2432           return 0;
2433         }
2434     }
2435   return 0;
2436 }
2437
2438
2439 DEFUN ("symbol-value-in-buffer", Fsymbol_value_in_buffer, 2, 3, 0, /*
2440 Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound.
2441 */
2442        (symbol, buffer, unbound_value))
2443 {
2444   Lisp_Object value;
2445   CHECK_SYMBOL (symbol);
2446   CHECK_BUFFER (buffer);
2447   value = symbol_value_in_buffer (symbol, buffer);
2448   return UNBOUNDP (value) ? unbound_value : value;
2449 }
2450
2451 DEFUN ("symbol-value-in-console", Fsymbol_value_in_console, 2, 3, 0, /*
2452 Return the value of SYMBOL in CONSOLE, or UNBOUND-VALUE if it is unbound.
2453 */
2454        (symbol, console, unbound_value))
2455 {
2456   Lisp_Object value;
2457   CHECK_SYMBOL (symbol);
2458   CHECK_CONSOLE (console);
2459   value = symbol_value_in_console (symbol, console);
2460   return UNBOUNDP (value) ? unbound_value : value;
2461 }
2462
2463 DEFUN ("built-in-variable-type", Fbuilt_in_variable_type, 1, 1, 0, /*
2464 If SYMBOL is a built-in variable, return info about this; else return nil.
2465 The returned info will be a symbol, one of
2466
2467 `object'                A simple built-in variable.
2468 `const-object'          Same, but cannot be set.
2469 `integer'               A built-in integer variable.
2470 `const-integer'         Same, but cannot be set.
2471 `boolean'               A built-in boolean variable.
2472 `const-boolean'         Same, but cannot be set.
2473 `const-specifier'       Always contains a specifier; e.g. `has-modeline-p'.
2474 `current-buffer'        A built-in buffer-local variable.
2475 `const-current-buffer'  Same, but cannot be set.
2476 `default-buffer'        Forwards to the default value of a built-in
2477                         buffer-local variable.
2478 `selected-console'      A built-in console-local variable.
2479 `const-selected-console' Same, but cannot be set.
2480 `default-console'       Forwards to the default value of a built-in
2481                         console-local variable.
2482 */
2483        (symbol))
2484 {
2485   REGISTER Lisp_Object valcontents;
2486
2487   CHECK_SYMBOL (symbol);
2488
2489  retry:
2490   valcontents = XSYMBOL (symbol)->value;
2491
2492  retry_2:
2493   if (!SYMBOL_VALUE_MAGIC_P (valcontents))
2494     return Qnil;
2495
2496   switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
2497     {
2498     case SYMVAL_LISP_MAGIC:
2499       valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
2500       /* semi-change-o */
2501       goto retry_2;
2502
2503     case SYMVAL_VARALIAS:
2504       symbol = follow_varalias_pointers (symbol, Qt);
2505       /* presto change-o! */
2506       goto retry;
2507
2508     case SYMVAL_BUFFER_LOCAL:
2509     case SYMVAL_SOME_BUFFER_LOCAL:
2510       valcontents =
2511         XSYMBOL_VALUE_BUFFER_LOCAL (valcontents)->current_value;
2512       /* semi-change-o */
2513       goto retry_2;
2514
2515     case SYMVAL_FIXNUM_FORWARD:                 return Qinteger;
2516     case SYMVAL_CONST_FIXNUM_FORWARD:           return Qconst_integer;
2517     case SYMVAL_BOOLEAN_FORWARD:                return Qboolean;
2518     case SYMVAL_CONST_BOOLEAN_FORWARD:          return Qconst_boolean;
2519     case SYMVAL_OBJECT_FORWARD:                 return Qobject;
2520     case SYMVAL_CONST_OBJECT_FORWARD:           return Qconst_object;
2521     case SYMVAL_CONST_SPECIFIER_FORWARD:        return Qconst_specifier;
2522     case SYMVAL_DEFAULT_BUFFER_FORWARD:         return Qdefault_buffer;
2523     case SYMVAL_CURRENT_BUFFER_FORWARD:         return Qcurrent_buffer;
2524     case SYMVAL_CONST_CURRENT_BUFFER_FORWARD:   return Qconst_current_buffer;
2525     case SYMVAL_DEFAULT_CONSOLE_FORWARD:        return Qdefault_console;
2526     case SYMVAL_SELECTED_CONSOLE_FORWARD:       return Qselected_console;
2527     case SYMVAL_CONST_SELECTED_CONSOLE_FORWARD: return Qconst_selected_console;
2528     case SYMVAL_UNBOUND_MARKER:                 return Qnil;
2529
2530     default:
2531       abort (); return Qnil;
2532     }
2533 }
2534
2535
2536 DEFUN ("local-variable-p", Flocal_variable_p, 2, 3, 0, /*
2537 Return t if SYMBOL's value is local to BUFFER.
2538 If optional third arg AFTER-SET is true, return t if SYMBOL would be
2539 buffer-local after it is set, regardless of whether it is so presently.
2540 A nil value for BUFFER is *not* the same as (current-buffer), but means
2541 "no buffer".  Specifically:
2542
2543 -- If BUFFER is nil and AFTER-SET is nil, a return value of t indicates that
2544    the variable is one of the special built-in variables that is always
2545    buffer-local. (This includes `buffer-file-name', `buffer-read-only',
2546    `buffer-undo-list', and others.)
2547
2548 -- If BUFFER is nil and AFTER-SET is t, a return value of t indicates that
2549    the variable has had `make-variable-buffer-local' applied to it.
2550 */
2551        (symbol, buffer, after_set))
2552 {
2553   int local_info;
2554
2555   CHECK_SYMBOL (symbol);
2556   if (!NILP (buffer))
2557     {
2558       buffer = get_buffer (buffer, 1);
2559       local_info = symbol_value_buffer_local_info (symbol, XBUFFER (buffer));
2560     }
2561   else
2562     {
2563       local_info = symbol_value_buffer_local_info (symbol, 0);
2564     }
2565
2566   if (NILP (after_set))
2567     return local_info > 0 ? Qt : Qnil;
2568   else
2569     return local_info != 0 ? Qt : Qnil;
2570 }
2571 \f
2572
2573 /*
2574 I've gone ahead and partially implemented this because it's
2575 super-useful for dealing with the compatibility problems in supporting
2576 the old pointer-shape variables, and preventing people from `setq'ing
2577 the new variables.  Any other way of handling this problem is way
2578 ugly, likely to be slow, and generally not something I want to waste
2579 my time worrying about.
2580
2581 The interface and/or function name is sure to change before this
2582 gets into its final form.  I currently like the way everything is
2583 set up and it has all the features I want it to have, except for
2584 one: I really want to be able to have multiple nested handlers,
2585 to implement an `advice'-like capability.  This would allow,
2586 for example, a clean way of implementing `debug-if-set' or
2587 `debug-if-referenced' and such.
2588
2589 NOTE NOTE NOTE NOTE NOTE NOTE NOTE:
2590 ************************************************************
2591 **Only** the `set-value', `make-unbound', and `make-local'
2592 handler types are currently implemented.  Implementing the
2593 get-value and bound-predicate handlers is somewhat tricky
2594 because there are lots of subfunctions (e.g. find_symbol_value()).
2595 find_symbol_value(), in fact, is called from outside of
2596 this module.  You'd have to have it do this:
2597
2598 -- check for a `bound-predicate' handler, call that if so;
2599    if it returns nil, return Qunbound
2600 -- check for a `get-value' handler and call it and return
2601    that value
2602
2603 It gets even trickier when you have to deal with
2604 sub-subfunctions like find_symbol_value_1(), and esp.
2605 when you have to properly handle variable aliases, which
2606 can lead to lots of tricky situations.  So I've just
2607 punted on this, since the interface isn't officially
2608 exported and we can get by with just a `set-value'
2609 handler.
2610
2611 Actions in unimplemented handler types will correctly
2612 ignore any handlers, and will not fuck anything up or
2613 go awry.
2614
2615 WARNING WARNING: If you do go and implement another
2616 type of handler, make *sure* to change
2617 would_be_magic_handled() so it knows about this,
2618 or dire things could result.
2619 ************************************************************
2620 NOTE NOTE NOTE NOTE NOTE NOTE NOTE
2621
2622 Real documentation is as follows.
2623
2624 Set a magic handler for VARIABLE.
2625 This allows you to specify arbitrary behavior that results from
2626 accessing or setting a variable.  For example, retrieving the
2627 variable's value might actually retrieve the first element off of
2628 a list stored in another variable, and setting the variable's value
2629 might add an element to the front of that list. (This is how the
2630 obsolete variable `unread-command-event' is implemented.)
2631
2632 In general it is NOT good programming practice to use magic variables
2633 in a new package that you are designing.  If you feel the need to
2634 do this, it's almost certainly a sign that you should be using a
2635 function instead of a variable.  This facility is provided to allow
2636 a package to support obsolete variables and provide compatibility
2637 with similar packages with different variable names and semantics.
2638 By using magic handlers, you can cleanly provide obsoleteness and
2639 compatibility support and separate this support from the core
2640 routines in a package.
2641
2642 VARIABLE should be a symbol naming the variable for which the
2643 magic behavior is provided.  HANDLER-TYPE is a symbol specifying
2644 which behavior is being controlled, and HANDLER is the function
2645 that will be called to control this behavior.  HARG is a
2646 value that will be passed to HANDLER but is otherwise
2647 uninterpreted.  KEEP-EXISTING specifies what to do with existing
2648 handlers of the same type; nil means "erase them all", t means
2649 "keep them but insert at the beginning", the list (t) means
2650 "keep them but insert at the end", a function means "keep
2651 them but insert before the specified function", a list containing
2652 a function means "keep them but insert after the specified
2653 function".
2654
2655 You can specify magic behavior for any type of variable at all,
2656 and for any handler types that are unspecified, the standard
2657 behavior applies.  This allows you, for example, to use
2658 `defvaralias' in conjunction with this function. (For that
2659 matter, `defvaralias' could be implemented using this function.)
2660
2661 The behaviors that can be specified in HANDLER-TYPE are
2662
2663 get-value               (SYM ARGS FUN HARG HANDLERS)
2664     This means that one of the functions `symbol-value',
2665     `default-value', `symbol-value-in-buffer', or
2666     `symbol-value-in-console' was called on SYM.
2667
2668 set-value               (SYM ARGS FUN HARG HANDLERS)
2669     This means that one of the functions `set' or `set-default'
2670     was called on SYM.
2671
2672 bound-predicate         (SYM ARGS FUN HARG HANDLERS)
2673     This means that one of the functions `boundp', `globally-boundp',
2674     or `default-boundp' was called on SYM.
2675
2676 make-unbound            (SYM ARGS FUN HARG HANDLERS)
2677     This means that the function `makunbound' was called on SYM.
2678
2679 local-predicate         (SYM ARGS FUN HARG HANDLERS)
2680     This means that the function `local-variable-p' was called
2681     on SYM.
2682
2683 make-local              (SYM ARGS FUN HARG HANDLERS)
2684     This means that one of the functions `make-local-variable',
2685     `make-variable-buffer-local', `kill-local-variable',
2686     or `kill-console-local-variable' was called on SYM.
2687
2688 The meanings of the arguments are as follows:
2689
2690    SYM is the symbol on which the function was called, and is always
2691    the first argument to the function.
2692
2693    ARGS are the remaining arguments in the original call (i.e. all
2694    but the first).  In the case of `set-value' in particular,
2695    the first element of ARGS is the value to which the variable
2696    is being set.  In some cases, ARGS is sanitized from what was
2697    actually given.  For example, whenever `nil' is passed to an
2698    argument and it means `current-buffer', the current buffer is
2699    substituted instead.
2700
2701    FUN is a symbol indicating which function is being called.
2702    For many of the functions, you can determine the corresponding
2703    function of a different class using
2704    `symbol-function-corresponding-function'.
2705
2706    HARG is the argument that was given in the call
2707    to `set-symbol-value-handler' for SYM and HANDLER-TYPE.
2708
2709    HANDLERS is a structure containing the remaining handlers
2710    for the variable; to call one of them, use
2711    `chain-to-symbol-value-handler'.
2712
2713 NOTE: You may *not* modify the list in ARGS, and if you want to
2714 keep it around after the handler function exits, you must make
2715 a copy using `copy-sequence'. (Same caveats for HANDLERS also.)
2716 */
2717
2718 static enum lisp_magic_handler
2719 decode_magic_handler_type (Lisp_Object symbol)
2720 {
2721   if (EQ (symbol, Qget_value))       return MAGIC_HANDLER_GET_VALUE;
2722   if (EQ (symbol, Qset_value))       return MAGIC_HANDLER_SET_VALUE;
2723   if (EQ (symbol, Qbound_predicate)) return MAGIC_HANDLER_BOUND_PREDICATE;
2724   if (EQ (symbol, Qmake_unbound))    return MAGIC_HANDLER_MAKE_UNBOUND;
2725   if (EQ (symbol, Qlocal_predicate)) return MAGIC_HANDLER_LOCAL_PREDICATE;
2726   if (EQ (symbol, Qmake_local))      return MAGIC_HANDLER_MAKE_LOCAL;
2727
2728   signal_simple_error ("Unrecognized symbol value handler type", symbol);
2729   abort ();
2730   return MAGIC_HANDLER_MAX;
2731 }
2732
2733 static enum lisp_magic_handler
2734 handler_type_from_function_symbol (Lisp_Object funsym, int abort_if_not_found)
2735 {
2736   if (EQ (funsym, Qsymbol_value)
2737       || EQ (funsym, Qdefault_value)
2738       || EQ (funsym, Qsymbol_value_in_buffer)
2739       || EQ (funsym, Qsymbol_value_in_console))
2740     return MAGIC_HANDLER_GET_VALUE;
2741
2742   if (EQ (funsym, Qset)
2743       || EQ (funsym, Qset_default))
2744     return MAGIC_HANDLER_SET_VALUE;
2745
2746   if (EQ (funsym, Qboundp)
2747       || EQ (funsym, Qglobally_boundp)
2748       || EQ (funsym, Qdefault_boundp))
2749     return MAGIC_HANDLER_BOUND_PREDICATE;
2750
2751   if (EQ (funsym, Qmakunbound))
2752     return MAGIC_HANDLER_MAKE_UNBOUND;
2753
2754   if (EQ (funsym, Qlocal_variable_p))
2755     return MAGIC_HANDLER_LOCAL_PREDICATE;
2756
2757   if (EQ (funsym, Qmake_variable_buffer_local)
2758       || EQ (funsym, Qmake_local_variable))
2759     return MAGIC_HANDLER_MAKE_LOCAL;
2760
2761   if (abort_if_not_found)
2762     abort ();
2763   signal_simple_error ("Unrecognized symbol-value function", funsym);
2764   return MAGIC_HANDLER_MAX;
2765 }
2766
2767 static int
2768 would_be_magic_handled (Lisp_Object sym, Lisp_Object funsym)
2769 {
2770   /* does not take into account variable aliasing. */
2771   Lisp_Object valcontents = XSYMBOL (sym)->value;
2772   enum lisp_magic_handler slot;
2773
2774   if (!SYMBOL_VALUE_LISP_MAGIC_P (valcontents))
2775     return 0;
2776   slot = handler_type_from_function_symbol (funsym, 1);
2777   if (slot != MAGIC_HANDLER_SET_VALUE && slot != MAGIC_HANDLER_MAKE_UNBOUND
2778       && slot != MAGIC_HANDLER_MAKE_LOCAL)
2779     /* #### temporary kludge because we haven't implemented
2780        lisp-magic variables completely */
2781     return 0;
2782   return !NILP (XSYMBOL_VALUE_LISP_MAGIC (valcontents)->handler[slot]);
2783 }
2784
2785 static Lisp_Object
2786 fetch_value_maybe_past_magic (Lisp_Object sym,
2787                               Lisp_Object follow_past_lisp_magic)
2788 {
2789   Lisp_Object value = XSYMBOL (sym)->value;
2790   if (SYMBOL_VALUE_LISP_MAGIC_P (value)
2791       && (EQ (follow_past_lisp_magic, Qt)
2792           || (!NILP (follow_past_lisp_magic)
2793               && !would_be_magic_handled (sym, follow_past_lisp_magic))))
2794     value = XSYMBOL_VALUE_LISP_MAGIC (value)->shadowed;
2795   return value;
2796 }
2797
2798 static Lisp_Object *
2799 value_slot_past_magic (Lisp_Object sym)
2800 {
2801   Lisp_Object *store_pointer = &XSYMBOL (sym)->value;
2802
2803   if (SYMBOL_VALUE_LISP_MAGIC_P (*store_pointer))
2804     store_pointer = &XSYMBOL_VALUE_LISP_MAGIC (sym)->shadowed;
2805   return store_pointer;
2806 }
2807
2808 static Lisp_Object
2809 maybe_call_magic_handler (Lisp_Object sym, Lisp_Object funsym, int nargs, ...)
2810 {
2811   va_list vargs;
2812   Lisp_Object args[20]; /* should be enough ... */
2813   int i;
2814   enum lisp_magic_handler htype;
2815   Lisp_Object legerdemain;
2816   struct symbol_value_lisp_magic *bfwd;
2817
2818   assert (nargs >= 0 && nargs < 20);
2819   legerdemain = XSYMBOL (sym)->value;
2820   assert (SYMBOL_VALUE_LISP_MAGIC_P (legerdemain));
2821   bfwd = XSYMBOL_VALUE_LISP_MAGIC (legerdemain);
2822
2823   va_start (vargs, nargs);
2824   for (i = 0; i < nargs; i++)
2825     args[i] = va_arg (vargs, Lisp_Object);
2826   va_end (vargs);
2827
2828   htype = handler_type_from_function_symbol (funsym, 1);
2829   if (NILP (bfwd->handler[htype]))
2830     return Qunbound;
2831   /* #### should be reusing the arglist, not always consing anew.
2832      Repeated handler invocations should not cause repeated consing.
2833      Doesn't matter for now, because this is just a quick implementation
2834      for obsolescence support. */
2835   return call5 (bfwd->handler[htype], sym, Flist (nargs, args), funsym,
2836                 bfwd->harg[htype], Qnil);
2837 }
2838
2839 DEFUN ("dontusethis-set-symbol-value-handler", Fdontusethis_set_symbol_value_handler,
2840        3, 5, 0, /*
2841 Don't you dare use this.
2842 If you do, suffer the wrath of Ben, who is likely to rename
2843 this function (or change the semantics of its arguments) without
2844 pity, thereby invalidating your code.
2845 */
2846        (variable, handler_type, handler, harg, keep_existing))
2847 {
2848   Lisp_Object valcontents;
2849   struct symbol_value_lisp_magic *bfwd;
2850   enum lisp_magic_handler htype;
2851   int i;
2852
2853   /* #### WARNING, only some handler types are implemented.  See above.
2854      Actions of other types will ignore a handler if it's there.
2855
2856      #### Also, `chain-to-symbol-value-handler' and
2857      `symbol-function-corresponding-function' are not implemented. */
2858   CHECK_SYMBOL (variable);
2859   CHECK_SYMBOL (handler_type);
2860   htype = decode_magic_handler_type (handler_type);
2861   valcontents = XSYMBOL (variable)->value;
2862   if (!SYMBOL_VALUE_LISP_MAGIC_P (valcontents))
2863     {
2864       bfwd = alloc_lcrecord_type (struct symbol_value_lisp_magic,
2865                                   &lrecord_symbol_value_lisp_magic);
2866       bfwd->magic.type = SYMVAL_LISP_MAGIC;
2867       for (i = 0; i < MAGIC_HANDLER_MAX; i++)
2868         {
2869           bfwd->handler[i] = Qnil;
2870           bfwd->harg[i] = Qnil;
2871         }
2872       bfwd->shadowed = valcontents;
2873       XSETSYMBOL_VALUE_MAGIC (XSYMBOL (variable)->value, bfwd);
2874     }
2875   else
2876     bfwd = XSYMBOL_VALUE_LISP_MAGIC (valcontents);
2877   bfwd->handler[htype] = handler;
2878   bfwd->harg[htype] = harg;
2879
2880   for (i = 0; i < MAGIC_HANDLER_MAX; i++)
2881     if (!NILP (bfwd->handler[i]))
2882       break;
2883
2884   if (i == MAGIC_HANDLER_MAX)
2885     /* there are no remaining handlers, so remove the structure. */
2886     XSYMBOL (variable)->value = bfwd->shadowed;
2887
2888   return Qnil;
2889 }
2890
2891 \f
2892 /* functions for working with variable aliases.  */
2893
2894 /* Follow the chain of variable aliases for SYMBOL.  Return the
2895    resulting symbol, whose value cell is guaranteed not to be a
2896    symbol-value-varalias.
2897
2898    Also maybe follow past symbol-value-lisp-magic -> symbol-value-varalias.
2899    If FUNSYM is t, always follow in such a case.  If FUNSYM is nil,
2900    never follow; stop right there.  Otherwise FUNSYM should be a
2901    recognized symbol-value function symbol; this means, follow
2902    unless there is a special handler for the named function.
2903
2904    OK, there is at least one reason why it's necessary for
2905    FOLLOW-PAST-LISP-MAGIC to be specified correctly: So that we
2906    can always be sure to catch cyclic variable aliasing.  If we never
2907    follow past Lisp magic, then if the following is done:
2908
2909    (defvaralias 'a 'b)
2910    add some magic behavior to a, but not a "get-value" handler
2911    (defvaralias 'b 'a)
2912
2913    then an attempt to retrieve a's or b's value would cause infinite
2914    looping in `symbol-value'.
2915
2916    We (of course) can't always follow past Lisp magic, because then
2917    we make any variable that is lisp-magic -> varalias behave as if
2918    the lisp-magic is not present at all.
2919  */
2920
2921 static Lisp_Object
2922 follow_varalias_pointers (Lisp_Object symbol,
2923                           Lisp_Object follow_past_lisp_magic)
2924 {
2925 #define VARALIAS_INDIRECTION_SUSPICION_LENGTH 16
2926   Lisp_Object tortoise, hare, val;
2927   int count;
2928
2929   /* quick out just in case */
2930   if (!SYMBOL_VALUE_MAGIC_P (XSYMBOL (symbol)->value))
2931     return symbol;
2932
2933   /* Compare implementation of indirect_function().  */
2934   for (hare = tortoise = symbol, count = 0;
2935        val = fetch_value_maybe_past_magic (hare, follow_past_lisp_magic),
2936          SYMBOL_VALUE_VARALIAS_P (val);
2937        hare = symbol_value_varalias_aliasee (XSYMBOL_VALUE_VARALIAS (val)),
2938          count++)
2939     {
2940       if (count < VARALIAS_INDIRECTION_SUSPICION_LENGTH) continue;
2941
2942       if (count & 1)
2943         tortoise = symbol_value_varalias_aliasee
2944           (XSYMBOL_VALUE_VARALIAS (fetch_value_maybe_past_magic
2945                                    (tortoise, follow_past_lisp_magic)));
2946       if (EQ (hare, tortoise))
2947         return Fsignal (Qcyclic_variable_indirection, list1 (symbol));
2948     }
2949
2950   return hare;
2951 }
2952
2953 DEFUN ("defvaralias", Fdefvaralias, 2, 2, 0, /*
2954 Define a variable as an alias for another variable.
2955 Thenceforth, any operations performed on VARIABLE will actually be
2956 performed on ALIAS.  Both VARIABLE and ALIAS should be symbols.
2957 If ALIAS is nil, remove any aliases for VARIABLE.
2958 ALIAS can itself be aliased, and the chain of variable aliases
2959 will be followed appropriately.
2960 If VARIABLE already has a value, this value will be shadowed
2961 until the alias is removed, at which point it will be restored.
2962 Currently VARIABLE cannot be a built-in variable, a variable that
2963 has a buffer-local value in any buffer, or the symbols nil or t.
2964 \(ALIAS, however, can be any type of variable.)
2965 */
2966        (variable, alias))
2967 {
2968   struct symbol_value_varalias *bfwd;
2969   Lisp_Object valcontents;
2970
2971   CHECK_SYMBOL (variable);
2972   reject_constant_symbols (variable, Qunbound, 0, Qt);
2973
2974   valcontents = XSYMBOL (variable)->value;
2975
2976   if (NILP (alias))
2977     {
2978       if (SYMBOL_VALUE_VARALIAS_P (valcontents))
2979         {
2980           XSYMBOL (variable)->value =
2981             symbol_value_varalias_shadowed
2982               (XSYMBOL_VALUE_VARALIAS (valcontents));
2983         }
2984       return Qnil;
2985     }
2986
2987   CHECK_SYMBOL (alias);
2988   if (SYMBOL_VALUE_VARALIAS_P (valcontents))
2989     {
2990       /* transmogrify */
2991       XSYMBOL_VALUE_VARALIAS (valcontents)->aliasee = alias;
2992       return Qnil;
2993     }
2994
2995   if (SYMBOL_VALUE_MAGIC_P (valcontents)
2996       && !UNBOUNDP (valcontents))
2997     signal_simple_error ("Variable is magic and cannot be aliased", variable);
2998   reject_constant_symbols (variable, Qunbound, 0, Qt);
2999
3000   bfwd = alloc_lcrecord_type (struct symbol_value_varalias,
3001                               &lrecord_symbol_value_varalias);
3002   bfwd->magic.type = SYMVAL_VARALIAS;
3003   bfwd->aliasee = alias;
3004   bfwd->shadowed = valcontents;
3005
3006   XSETSYMBOL_VALUE_MAGIC (valcontents, bfwd);
3007   XSYMBOL (variable)->value = valcontents;
3008   return Qnil;
3009 }
3010
3011 DEFUN ("variable-alias", Fvariable_alias, 1, 2, 0, /*
3012 If VARIABLE is aliased to another variable, return that variable.
3013 VARIABLE should be a symbol.  If VARIABLE is not aliased, return nil.
3014 Variable aliases are created with `defvaralias'.  See also
3015 `indirect-variable'.
3016 */
3017        (variable, follow_past_lisp_magic))
3018 {
3019   Lisp_Object valcontents;
3020
3021   CHECK_SYMBOL (variable);
3022   if (!NILP (follow_past_lisp_magic) && !EQ (follow_past_lisp_magic, Qt))
3023     {
3024       CHECK_SYMBOL (follow_past_lisp_magic);
3025       handler_type_from_function_symbol (follow_past_lisp_magic, 0);
3026     }
3027
3028   valcontents = fetch_value_maybe_past_magic (variable,
3029                                               follow_past_lisp_magic);
3030
3031   if (SYMBOL_VALUE_VARALIAS_P (valcontents))
3032     return symbol_value_varalias_aliasee
3033       (XSYMBOL_VALUE_VARALIAS (valcontents));
3034   else
3035     return Qnil;
3036 }
3037
3038 DEFUN ("indirect-variable", Findirect_variable, 1, 2, 0, /*
3039 Return the variable at the end of OBJECT's variable-alias chain.
3040 If OBJECT is a symbol, follow all variable aliases and return
3041 the final (non-aliased) symbol.  Variable aliases are created with
3042 the function `defvaralias'.
3043 If OBJECT is not a symbol, just return it.
3044 Signal a cyclic-variable-indirection error if there is a loop in the
3045 variable chain of symbols.
3046 */
3047        (object, follow_past_lisp_magic))
3048 {
3049   if (!SYMBOLP (object))
3050     return object;
3051   if (!NILP (follow_past_lisp_magic) && !EQ (follow_past_lisp_magic, Qt))
3052     {
3053       CHECK_SYMBOL (follow_past_lisp_magic);
3054       handler_type_from_function_symbol (follow_past_lisp_magic, 0);
3055     }
3056   return follow_varalias_pointers (object, follow_past_lisp_magic);
3057 }
3058
3059 \f
3060 /************************************************************************/
3061 /*                            initialization                            */
3062 /************************************************************************/
3063
3064 /* A dumped XEmacs image has a lot more than 1511 symbols.  Last
3065    estimate was that there were actually around 6300.  So let's try
3066    making this bigger and see if we get better hashing behavior. */
3067 #define OBARRAY_SIZE 16411
3068
3069 #ifndef Qzero
3070 Lisp_Object Qzero;
3071 #endif
3072 #ifndef Qnull_pointer
3073 Lisp_Object Qnull_pointer;
3074 #endif
3075
3076 /* some losing systems can't have static vars at function scope... */
3077 static struct symbol_value_magic guts_of_unbound_marker =
3078   { { symbol_value_forward_lheader_initializer, 0, 69},
3079     SYMVAL_UNBOUND_MARKER };
3080
3081 void
3082 init_symbols_once_early (void)
3083 {
3084 #ifndef Qzero
3085   Qzero = make_int (0); /* Only used if Lisp_Object is a union type */
3086 #endif
3087
3088 #ifndef Qnull_pointer
3089   /* C guarantees that Qnull_pointer will be initialized to all 0 bits,
3090      so the following is actually a no-op.  */
3091   XSETOBJ (Qnull_pointer, (enum Lisp_Type) 0, 0);
3092 #endif
3093
3094   /* Bootstrapping problem: Qnil isn't set when make_string_nocopy is
3095      called the first time. */
3096   Qnil = Fmake_symbol (make_string_nocopy ((CONST Bufbyte *) "nil", 3));
3097   XSYMBOL (Qnil)->name->plist = Qnil;
3098   XSYMBOL (Qnil)->value = Qnil; /* Nihil ex nihil */
3099   XSYMBOL (Qnil)->plist = Qnil;
3100
3101   Vobarray = make_vector (OBARRAY_SIZE, Qzero);
3102   initial_obarray = Vobarray;
3103   staticpro (&initial_obarray);
3104   /* Intern nil in the obarray */
3105   {
3106     int hash = hash_string (string_data (XSYMBOL (Qnil)->name), 3);
3107     XVECTOR_DATA (Vobarray)[hash % OBARRAY_SIZE] = Qnil;
3108   }
3109
3110   {
3111     /* Required to get around a GCC syntax error on certain
3112        architectures */
3113     struct symbol_value_magic *tem = &guts_of_unbound_marker;
3114
3115     XSETSYMBOL_VALUE_MAGIC (Qunbound, tem);
3116   }
3117   if ((CONST void *) XPNTR (Qunbound) !=
3118       (CONST void *)&guts_of_unbound_marker)
3119     {
3120       /* This might happen on DATA_SEG_BITS machines. */
3121       /* abort (); */
3122       /* Can't represent a pointer to constant C data using a Lisp_Object.
3123          So heap-allocate it. */
3124       struct symbol_value_magic *urk = xnew (struct symbol_value_magic);
3125       memcpy (urk, &guts_of_unbound_marker, sizeof (*urk));
3126       XSETSYMBOL_VALUE_MAGIC (Qunbound, urk);
3127     }
3128
3129   XSYMBOL (Qnil)->function = Qunbound;
3130
3131   defsymbol (&Qt, "t");
3132   XSYMBOL (Qt)->value = Qt;     /* Veritas aetera */
3133   Vquit_flag = Qnil;
3134 }
3135
3136 void
3137 defsymbol (Lisp_Object *location, CONST char *name)
3138 {
3139   *location = Fintern (make_string_nocopy ((CONST Bufbyte *) name,
3140                                            strlen (name)),
3141                        Qnil);
3142   staticpro (location);
3143 }
3144
3145 void
3146 defkeyword (Lisp_Object *location, CONST char *name)
3147 {
3148   defsymbol (location, name);
3149   Fset (*location, *location);
3150 }
3151
3152 #ifdef DEBUG_XEMACS
3153 /* Check that nobody spazzed writing a DEFUN. */
3154 static void
3155 check_sane_subr (Lisp_Subr *subr, Lisp_Object sym)
3156 {
3157   assert (subr->min_args >= 0);
3158   assert (subr->min_args <= SUBR_MAX_ARGS);
3159
3160   if (subr->max_args != MANY &&
3161       subr->max_args != UNEVALLED)
3162     {
3163       /* Need to fix lisp.h and eval.c if SUBR_MAX_ARGS too small */
3164       assert (subr->max_args <= SUBR_MAX_ARGS);
3165       assert (subr->min_args <= subr->max_args);
3166     }
3167
3168   assert (UNBOUNDP (XSYMBOL (sym)->function));
3169 }
3170 #else
3171 #define check_sane_subr(subr, sym) /* nothing */
3172 #endif
3173
3174 #ifdef HAVE_SHLIB
3175 /*
3176  * If we are not in a pure undumped Emacs, we need to make a duplicate of
3177  * the subr. This is because the only time this function will be called
3178  * in a running Emacs is when a dynamically loaded module is adding a
3179  * subr, and we need to make sure that the subr is in allocated, Lisp-
3180  * accessible memory.  The address assigned to the static subr struct
3181  * in the shared object will be a trampoline address, so we need to create
3182  * a copy here to ensure that a real address is used.
3183  *
3184  * Once we have copied everything across, we re-use the original static
3185  * structure to store a pointer to the newly allocated one. This will be
3186  * used in emodules.c by emodules_doc_subr() to find a pointer to the
3187  * allocated object so that we can set its doc string propperly.
3188  *
3189  * NOTE: We dont actually use the DOC pointer here any more, but we did
3190  * in an earlier implementation of module support. There is no harm in
3191  * setting it here in case we ever need it in future implementations.
3192  * subr->doc will point to the new subr structure that was allocated.
3193  * Code can then get this value from the statis subr structure and use
3194  * it if required.
3195  *
3196  * FIXME: Should newsubr be staticpro()'ed? I dont think so but I need
3197  * a guru to check.
3198  */
3199 #define check_module_subr()                                             \
3200 do {                                                                    \
3201   if (initialized) {                                                    \
3202     struct Lisp_Subr *newsubr;                                          \
3203     newsubr = (Lisp_Subr *)xmalloc(sizeof(struct Lisp_Subr));           \
3204     memcpy (newsubr, subr, sizeof(struct Lisp_Subr));                   \
3205     subr->doc = (CONST char *)newsubr;                                  \
3206     subr = newsubr;                                                     \
3207   }                                                                     \
3208 } while (0)
3209 #else /* ! HAVE_SHLIB */
3210 #define check_module_subr()
3211 #endif
3212
3213 void
3214 defsubr (Lisp_Subr *subr)
3215 {
3216   Lisp_Object sym = intern (subr_name (subr));
3217   Lisp_Object fun;
3218
3219   check_sane_subr (subr, sym);
3220   check_module_subr ();
3221
3222   XSETSUBR (fun, subr);
3223   XSYMBOL (sym)->function = fun;
3224 }
3225
3226 /* Define a lisp macro using a Lisp_Subr. */
3227 void
3228 defsubr_macro (Lisp_Subr *subr)
3229 {
3230   Lisp_Object sym = intern (subr_name (subr));
3231   Lisp_Object fun;
3232
3233   check_sane_subr (subr, sym);
3234   check_module_subr();
3235
3236   XSETSUBR (fun, subr);
3237   XSYMBOL (sym)->function = Fcons (Qmacro, fun);
3238 }
3239
3240 void
3241 deferror (Lisp_Object *symbol, CONST char *name, CONST char *messuhhj,
3242           Lisp_Object inherits_from)
3243 {
3244   Lisp_Object conds;
3245   defsymbol (symbol, name);
3246
3247   assert (SYMBOLP (inherits_from));
3248   conds = Fget (inherits_from, Qerror_conditions, Qnil);
3249   pure_put (*symbol, Qerror_conditions, Fcons (*symbol, conds));
3250   /* NOT build_translated_string ().  This function is called at load time
3251      and the string needs to get translated at run time.  (This happens
3252      in the function (display-error) in cmdloop.el.) */
3253   pure_put (*symbol, Qerror_message, build_string (messuhhj));
3254 }
3255
3256 void
3257 syms_of_symbols (void)
3258 {
3259   defsymbol (&Qvariable_documentation, "variable-documentation");
3260   defsymbol (&Qvariable_domain, "variable-domain");     /* I18N3 */
3261   defsymbol (&Qad_advice_info, "ad-advice-info");
3262   defsymbol (&Qad_activate, "ad-activate");
3263
3264   defsymbol (&Qget_value, "get-value");
3265   defsymbol (&Qset_value, "set-value");
3266   defsymbol (&Qbound_predicate, "bound-predicate");
3267   defsymbol (&Qmake_unbound, "make-unbound");
3268   defsymbol (&Qlocal_predicate, "local-predicate");
3269   defsymbol (&Qmake_local, "make-local");
3270
3271   defsymbol (&Qboundp, "boundp");
3272   defsymbol (&Qfboundp, "fboundp");
3273   defsymbol (&Qglobally_boundp, "globally-boundp");
3274   defsymbol (&Qmakunbound, "makunbound");
3275   defsymbol (&Qsymbol_value, "symbol-value");
3276   defsymbol (&Qset, "set");
3277   defsymbol (&Qsetq_default, "setq-default");
3278   defsymbol (&Qdefault_boundp, "default-boundp");
3279   defsymbol (&Qdefault_value, "default-value");
3280   defsymbol (&Qset_default, "set-default");
3281   defsymbol (&Qmake_variable_buffer_local, "make-variable-buffer-local");
3282   defsymbol (&Qmake_local_variable, "make-local-variable");
3283   defsymbol (&Qkill_local_variable, "kill-local-variable");
3284   defsymbol (&Qkill_console_local_variable, "kill-console-local-variable");
3285   defsymbol (&Qsymbol_value_in_buffer, "symbol-value-in-buffer");
3286   defsymbol (&Qsymbol_value_in_console, "symbol-value-in-console");
3287   defsymbol (&Qlocal_variable_p, "local-variable-p");
3288
3289   defsymbol (&Qconst_integer, "const-integer");
3290   defsymbol (&Qconst_boolean, "const-boolean");
3291   defsymbol (&Qconst_object, "const-object");
3292   defsymbol (&Qconst_specifier, "const-specifier");
3293   defsymbol (&Qdefault_buffer, "default-buffer");
3294   defsymbol (&Qcurrent_buffer, "current-buffer");
3295   defsymbol (&Qconst_current_buffer, "const-current-buffer");
3296   defsymbol (&Qdefault_console, "default-console");
3297   defsymbol (&Qselected_console, "selected-console");
3298   defsymbol (&Qconst_selected_console, "const-selected-console");
3299
3300   DEFSUBR (Fintern);
3301   DEFSUBR (Fintern_soft);
3302   DEFSUBR (Funintern);
3303   DEFSUBR (Fmapatoms);
3304   DEFSUBR (Fapropos_internal);
3305
3306   DEFSUBR (Fsymbol_function);
3307   DEFSUBR (Fsymbol_plist);
3308   DEFSUBR (Fsymbol_name);
3309   DEFSUBR (Fmakunbound);
3310   DEFSUBR (Ffmakunbound);
3311   DEFSUBR (Fboundp);
3312   DEFSUBR (Fglobally_boundp);
3313   DEFSUBR (Ffboundp);
3314   DEFSUBR (Ffset);
3315   DEFSUBR (Fdefine_function);
3316   Ffset (intern ("defalias"), intern ("define-function"));
3317   DEFSUBR (Fsetplist);
3318   DEFSUBR (Fsymbol_value_in_buffer);
3319   DEFSUBR (Fsymbol_value_in_console);
3320   DEFSUBR (Fbuilt_in_variable_type);
3321   DEFSUBR (Fsymbol_value);
3322   DEFSUBR (Fset);
3323   DEFSUBR (Fdefault_boundp);
3324   DEFSUBR (Fdefault_value);
3325   DEFSUBR (Fset_default);
3326   DEFSUBR (Fsetq_default);
3327   DEFSUBR (Fmake_variable_buffer_local);
3328   DEFSUBR (Fmake_local_variable);
3329   DEFSUBR (Fkill_local_variable);
3330   DEFSUBR (Fkill_console_local_variable);
3331   DEFSUBR (Flocal_variable_p);
3332   DEFSUBR (Fdefvaralias);
3333   DEFSUBR (Fvariable_alias);
3334   DEFSUBR (Findirect_variable);
3335   DEFSUBR (Fdontusethis_set_symbol_value_handler);
3336 }
3337
3338 /* Create and initialize a Lisp variable whose value is forwarded to C data */
3339 void
3340 defvar_magic (CONST char *symbol_name, CONST struct symbol_value_forward *magic)
3341 {
3342   Lisp_Object sym, kludge;
3343
3344   /* Check that `magic' points somewhere we can represent as a Lisp pointer */
3345   XSETOBJ (kludge, Lisp_Type_Record, magic);
3346   if ((void *)magic != (void*) XPNTR (kludge))
3347     {
3348       /* This might happen on DATA_SEG_BITS machines. */
3349       /* abort (); */
3350       /* Copy it to somewhere which is representable. */
3351       struct symbol_value_forward *p = xnew (struct symbol_value_forward);
3352       memcpy (p, magic, sizeof *magic);
3353       magic = p;
3354     }
3355
3356 #if defined(HAVE_SHLIB)
3357   /*
3358    * As with defsubr(), this will only be called in a dumped Emacs when
3359    * we are adding variables from a dynamically loaded module. That means
3360    * we can't use purespace. Take that into account.
3361    */
3362   if (initialized)
3363     sym = Fintern (build_string (symbol_name), Qnil);
3364   else
3365 #endif
3366     sym = Fintern (make_string_nocopy ((CONST Bufbyte *) symbol_name,
3367                                        strlen (symbol_name)), Qnil);
3368
3369   XSETOBJ (XSYMBOL (sym)->value, Lisp_Type_Record, magic);
3370 }
3371
3372 void
3373 vars_of_symbols (void)
3374 {
3375   DEFVAR_LISP ("obarray", &Vobarray /*
3376 Symbol table for use by `intern' and `read'.
3377 It is a vector whose length ought to be prime for best results.
3378 The vector's contents don't make sense if examined from Lisp programs;
3379 to find all the symbols in an obarray, use `mapatoms'.
3380 */ );
3381   /* obarray has been initialized long before */
3382 }