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