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