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