From: Alan Mackenzie Date: Sun, 11 Nov 2018 12:00:56 +0000 (+0000) Subject: First draught of creation of "located symbols". X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=580e66335a52222fb95ef3564a6480357ef5326f;p=emacs.git First draught of creation of "located symbols". This commit is the first on branch /scratch/accurate-warning-pos. * src/lisp.h (Lisp_Object, vectorlike_header, pvec_type, More_Lisp_Bits): Move to earlier on in the file to facilitate other changes. (Lisp_Located_Symbol): New struct type. (pvec_type): New entry PVEC_LOCATED_SYMBOL. (lisp_h_PSEUDOVECTORP): New macro. (lisp_h_LOCATED_SYMBOL_P, lisp_h_ONLY_SYMBOL_P, lisp_h_XONLY_SYMBOL) (lisp_h_XLOCATED_SYMBOL): New macros. (lisp_h_SYMBOLP, lisp_h_XSYMBOL): Macros enhanced to handle located symbols. (ONLY_SYMBOL_P, XONLY_SYMBOL): New macros. (LOCATED_SYMBOL_P, XLOCATED_SYMBOL, LOCATED_SYMBOL_SYM, LOCATED_SYMBOL_LOC): New inline functions. * src/alloc.c (build_located_symbol): New function * src/data.c (Ftype_of): New entry for PVEC_LOCATED_SYMBOL. (Fonly_symbol_p, Flocated_symbol_p, Flocated_symbol_sym, Flocated_symbol_loc): New defuns. (Vlocated_symbols_enabled): New Lisp variable. * src/fns.c (internal_equal): Replace located-symbols by their bare symbols for the purposes of comparison. * src/lread.c (read0, read1, read_list, read_vector, read_internal_start): Add a new bool argument locate_syms which means "convert symbol occurrences to located symbols". (read1): Add the code to perform the conversion to located symbols. (Fread_locating_symbols): New defun. * src/print.c (print_vectorlike): New switch arm for PVEC_LOCATED_SYMBOL. --- diff --git a/src/alloc.c b/src/alloc.c index 0e48b33882c..7961fc13b91 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3670,6 +3670,21 @@ make_misc_ptr (void *a) return make_lisp_ptr (p, Lisp_Vectorlike); } +/* Return a new located symbol with the specified SYMBOL and LOCATION. */ +Lisp_Object +build_located_symbol (Lisp_Object symbol, Lisp_Object location) +{ + Lisp_Object val; + struct Lisp_Located_Symbol *p + = (struct Lisp_Located_Symbol *) allocate_vector (2); + XSETVECTOR (val, p); + XSETPVECTYPESIZE (XVECTOR (val), PVEC_LOCATED_SYMBOL, 2, 0); + p->sym = symbol; + p->loc = location; + + return val; +} + /* Return a new overlay with specified START, END and PLIST. */ Lisp_Object diff --git a/src/data.c b/src/data.c index 538081e5c9b..768d87b6d6c 100644 --- a/src/data.c +++ b/src/data.c @@ -228,6 +228,7 @@ for example, (type-of 1) returns `integer'. */) case PVEC_NORMAL_VECTOR: return Qvector; case PVEC_BIGNUM: return Qinteger; case PVEC_MARKER: return Qmarker; + case PVEC_LOCATED_SYMBOL: return Qlocated_symbol; case PVEC_OVERLAY: return Qoverlay; case PVEC_FINALIZER: return Qfinalizer; #ifdef HAVE_MODULES @@ -326,6 +327,26 @@ DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, return Qt; } +DEFUN ("only-symbol-p", Fonly_symbol_p, Sonly_symbol_p, 1, 1, 0, + doc: /* Return t if OBJECT is a symbol, but not a located symbol. */ + attributes: const) + (Lisp_Object object) +{ + if (ONLY_SYMBOL_P (object)) + return Qt; + return Qnil; +} + +DEFUN ("located-symbol-p", Flocated_symbol_p, Slocated_symbol_p, 1, 1, 0, + doc: /* Return t if OBJECT is a located symbol. */ + attributes: const) + (Lisp_Object object) +{ + if (LOCATED_SYMBOL_P (object)) + return Qt; + return Qnil; +} + DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, doc: /* Return t if OBJECT is a symbol. */ attributes: const) @@ -751,6 +772,22 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, return name; } +DEFUN ("located-symbol-sym", Flocated_symbol_sym, Slocated_symbol_sym, 1, 1, 0, + doc: /* Return the symbol in a located symbol. */) + (register Lisp_Object ls) +{ + /* Type checking is done in the following macro. */ + return LOCATED_SYMBOL_SYM (ls); +} + +DEFUN ("located-symbol-loc", Flocated_symbol_loc, Slocated_symbol_loc, 1, 1, 0, + doc: /* Return the location in a located symbol. */) + (register Lisp_Object ls) +{ + /* Type checking is done in the following macro. */ + return LOCATED_SYMBOL_LOC (ls); +} + DEFUN ("fset", Ffset, Sfset, 2, 2, 0, doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */) (register Lisp_Object symbol, Lisp_Object definition) @@ -3818,6 +3855,8 @@ syms_of_data (void) DEFSYM (Qlistp, "listp"); DEFSYM (Qconsp, "consp"); + DEFSYM (Qonly_symbol_p, "only-symbol-p"); + DEFSYM (Qlocated_symbol_p, "located-symbol-p"); DEFSYM (Qsymbolp, "symbolp"); DEFSYM (Qfixnump, "fixnump"); DEFSYM (Qintegerp, "integerp"); @@ -3926,6 +3965,7 @@ syms_of_data (void) DEFSYM (Qstring, "string"); DEFSYM (Qcons, "cons"); DEFSYM (Qmarker, "marker"); + DEFSYM (Qlocated_symbol, "located-symbol"); DEFSYM (Qoverlay, "overlay"); DEFSYM (Qfinalizer, "finalizer"); #ifdef HAVE_MODULES @@ -3973,6 +4013,8 @@ syms_of_data (void) defsubr (&Snumber_or_marker_p); defsubr (&Sfloatp); defsubr (&Snatnump); + defsubr (&Sonly_symbol_p); + defsubr (&Slocated_symbol_p); defsubr (&Ssymbolp); defsubr (&Skeywordp); defsubr (&Sstringp); @@ -4003,6 +4045,8 @@ syms_of_data (void) defsubr (&Sindirect_function); defsubr (&Ssymbol_plist); defsubr (&Ssymbol_name); + defsubr (&Slocated_symbol_sym); + defsubr (&Slocated_symbol_loc); defsubr (&Smakunbound); defsubr (&Sfmakunbound); defsubr (&Sboundp); @@ -4078,6 +4122,11 @@ This variable cannot be set; trying to do so will signal an error. */); Vmost_negative_fixnum = make_fixnum (MOST_NEGATIVE_FIXNUM); make_symbol_constant (intern_c_string ("most-negative-fixnum")); + DEFVAR_LISP ("located-symbols-enabled", Vlocated_symbols_enabled, + doc: /* Non-nil when "located symbols" can be used in place of symbols. +Bind this to non-nil in applications such as the byte compiler. */); + Vlocated_symbols_enabled = Qnil; + DEFSYM (Qwatchers, "watchers"); DEFSYM (Qmakunbound, "makunbound"); DEFSYM (Qunlet, "unlet"); diff --git a/src/fns.c b/src/fns.c index c9a6dd6de1e..d421bc45b12 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2379,6 +2379,13 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, } } + /* A located symbol compares the contained symbol, and is `equal' to + the corresponding ordinary symbol. */ + if (LOCATED_SYMBOL_P (o1)) + o1 = LOCATED_SYMBOL_SYM (o1); + if (LOCATED_SYMBOL_P (o2)) + o2 = LOCATED_SYMBOL_SYM (o2); + if (EQ (o1, o2)) return true; if (XTYPE (o1) != XTYPE (o2)) diff --git a/src/lisp.h b/src/lisp.h index eb6762678c7..b4fc6f24ef9 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -323,6 +323,64 @@ typedef union Lisp_X *Lisp_Word; typedef EMACS_INT Lisp_Word; #endif +/* A Lisp_Object is a tagged pointer or integer. Ordinarily it is a + Lisp_Word. However, if CHECK_LISP_OBJECT_TYPE, it is a wrapper + around Lisp_Word, to help catch thinkos like 'Lisp_Object x = 0;'. + + LISP_INITIALLY (W) initializes a Lisp object with a tagged value + that is a Lisp_Word W. It can be used in a static initializer. */ + +#ifdef CHECK_LISP_OBJECT_TYPE +typedef struct Lisp_Object { Lisp_Word i; } Lisp_Object; +# define LISP_INITIALLY(w) {w} +# undef CHECK_LISP_OBJECT_TYPE +enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true }; +#else +typedef Lisp_Word Lisp_Object; +# define LISP_INITIALLY(w) (w) +enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = false }; +#endif + +/* Header of vector-like objects. This documents the layout constraints on + vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents + compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR + and PSEUDOVECTORP cast their pointers to union vectorlike_header *, + because when two such pointers potentially alias, a compiler won't + incorrectly reorder loads and stores to their size fields. See + Bug#8546. This union formerly contained more members, and there's + no compelling reason to change it to a struct merely because the + number of members has been reduced to one. */ +union vectorlike_header + { + /* The main member contains various pieces of information: + - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit. + - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain + vector (0) or a pseudovector (1). + - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number + of slots) of the vector. + - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields: + - a) pseudovector subtype held in PVEC_TYPE_MASK field; + - b) number of Lisp_Objects slots at the beginning of the object + held in PSEUDOVECTOR_SIZE_MASK field. These objects are always + traced by the GC; + - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and + measured in word_size units. Rest fields may also include + Lisp_Objects, but these objects usually needs some special treatment + during GC. + There are some exceptions. For PVEC_FREE, b) is always zero. For + PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero. + Current layout limits the pseudovectors to 63 PVEC_xxx subtypes, + 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */ + ptrdiff_t size; + }; + +struct Lisp_Located_Symbol + { + union vectorlike_header header; + Lisp_Object sym; /* A symbol */ + Lisp_Object loc; /* A fixnum */ + } GCALIGNED_STRUCT; + /* Some operations are so commonly executed that they are implemented as macros, not functions, because otherwise runtime performance would suffer too much when compiling with GCC without optimization. @@ -379,6 +437,97 @@ typedef EMACS_INT Lisp_Word; # endif #endif +/* In the size word of a vector, this bit means the vector has been marked. */ + +DEFINE_GDB_SYMBOL_BEGIN (ptrdiff_t, ARRAY_MARK_FLAG) +# define ARRAY_MARK_FLAG PTRDIFF_MIN +DEFINE_GDB_SYMBOL_END (ARRAY_MARK_FLAG) + +/* In the size word of a struct Lisp_Vector, this bit means it's really + some other vector-like object. */ +DEFINE_GDB_SYMBOL_BEGIN (ptrdiff_t, PSEUDOVECTOR_FLAG) +# define PSEUDOVECTOR_FLAG (PTRDIFF_MAX - PTRDIFF_MAX / 2) +DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG) + +/* In a pseudovector, the size field actually contains a word with one + PSEUDOVECTOR_FLAG bit set, and one of the following values extracted + with PVEC_TYPE_MASK to indicate the actual type. */ +enum pvec_type +{ + PVEC_NORMAL_VECTOR, + PVEC_FREE, + PVEC_BIGNUM, + PVEC_MARKER, + PVEC_OVERLAY, + PVEC_FINALIZER, + PVEC_LOCATED_SYMBOL, + PVEC_MISC_PTR, +#ifdef HAVE_MODULES + PVEC_USER_PTR, +#endif + PVEC_PROCESS, + PVEC_FRAME, + PVEC_WINDOW, + PVEC_BOOL_VECTOR, + PVEC_BUFFER, + PVEC_HASH_TABLE, + PVEC_TERMINAL, + PVEC_WINDOW_CONFIGURATION, + PVEC_SUBR, + PVEC_OTHER, /* Should never be visible to Elisp code. */ + PVEC_XWIDGET, + PVEC_XWIDGET_VIEW, + PVEC_THREAD, + PVEC_MUTEX, + PVEC_CONDVAR, + PVEC_MODULE_FUNCTION, + + /* These should be last, check internal_equal to see why. */ + PVEC_COMPILED, + PVEC_CHAR_TABLE, + PVEC_SUB_CHAR_TABLE, + PVEC_RECORD, + PVEC_FONT /* Should be last because it's used for range checking. */ +}; + +enum More_Lisp_Bits + { + /* For convenience, we also store the number of elements in these bits. + Note that this size is not necessarily the memory-footprint size, but + only the number of Lisp_Object fields (that need to be traced by GC). + The distinction is used, e.g., by Lisp_Process, which places extra + non-Lisp_Object fields at the end of the structure. */ + PSEUDOVECTOR_SIZE_BITS = 12, + PSEUDOVECTOR_SIZE_MASK = (1 << PSEUDOVECTOR_SIZE_BITS) - 1, + + /* To calculate the memory footprint of the pseudovector, it's useful + to store the size of non-Lisp area in word_size units here. */ + PSEUDOVECTOR_REST_BITS = 12, + PSEUDOVECTOR_REST_MASK = (((1 << PSEUDOVECTOR_REST_BITS) - 1) + << PSEUDOVECTOR_SIZE_BITS), + + /* Used to extract pseudovector subtype information. */ + PSEUDOVECTOR_AREA_BITS = PSEUDOVECTOR_SIZE_BITS + PSEUDOVECTOR_REST_BITS, + PVEC_TYPE_MASK = 0x3f << PSEUDOVECTOR_AREA_BITS + }; + +#define lisp_h_PSEUDOVECTORP(a,code) \ + (lisp_h_VECTORLIKEP(a) && \ + ((XUNTAG (a, Lisp_Vectorlike, union vectorlike_header)->size \ + & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \ + == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS)))) + + +/* These functions extract various sorts of values from a Lisp_Object. + For example, if tem is a Lisp_Object whose type is Lisp_Cons, + XCONS (tem) is the struct Lisp_Cons * pointing to the memory for + that cons. */ + +/* Largest and smallest representable fixnum values. These are the C + values. They are macros for use in #if and static initializers. */ +#define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS) +#define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM) + #define lisp_h_CHECK_FIXNUM(x) CHECK_TYPE (FIXNUMP (x), Qfixnump, x) #define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x) #define lisp_h_CHECK_TYPE(ok, predicate, x) \ @@ -399,7 +548,11 @@ typedef EMACS_INT Lisp_Word; #define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->u.s.trapped_write) #define lisp_h_SYMBOL_VAL(sym) \ (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), (sym)->u.s.val.value) -#define lisp_h_SYMBOLP(x) TAGGEDP (x, Lisp_Symbol) +#define lisp_h_LOCATED_SYMBOL_P(x) lisp_h_PSEUDOVECTORP (XIL(x), PVEC_LOCATED_SYMBOL) +#define lisp_h_ONLY_SYMBOL_P(x) TAGGEDP (x, Lisp_Symbol) +/* verify (NIL_IS_ZERO) */ +#define lisp_h_SYMBOLP(x) ((lisp_h_ONLY_SYMBOL_P (x) || \ + (Vlocated_symbols_enabled && (lisp_h_LOCATED_SYMBOL_P (x))))) #define lisp_h_TAGGEDP(a, tag) \ (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ - (unsigned) (tag)) \ @@ -419,18 +572,31 @@ typedef EMACS_INT Lisp_Word; # define lisp_h_XFIXNAT(a) XFIXNUM (a) # define lisp_h_XFIXNUM(a) (XLI (a) >> INTTYPEBITS) # ifdef __CHKP__ -# define lisp_h_XSYMBOL(a) \ - (eassert (SYMBOLP (a)), \ +# define lisp_h_XONLY_SYMBOL(a) \ + (eassert (ONLY_SYMBOL_P (a)), \ (struct Lisp_Symbol *) ((char *) XUNTAG (a, Lisp_Symbol, \ struct Lisp_Symbol) \ + (intptr_t) lispsym)) # else /* If !__CHKP__ this is equivalent, and is a bit faster as of GCC 7. */ -# define lisp_h_XSYMBOL(a) \ - (eassert (SYMBOLP (a)), \ +# define lisp_h_XONLY_SYMBOL(a) \ + (eassert (ONLY_SYMBOL_P (a)), \ (struct Lisp_Symbol *) ((intptr_t) XLI (a) - Lisp_Symbol \ + (char *) lispsym)) # endif +# define lisp_h_XLOCATED_SYMBOL(a) \ + (eassert (LOCATED_SYMBOL_P (a)), \ + (struct Lisp_Located_Symbol *) XUNTAG \ + (a, Lisp_Vectorlike, struct Lisp_Located_Symbol)) +/* verify (NIL_IS_ZERO) */ +# define lisp_h_XSYMBOL(a) \ + (eassert (SYMBOLP (a)), \ + (!Vlocated_symbols_enabled \ + ? (lisp_h_XONLY_SYMBOL (a)) \ + : (lisp_h_ONLY_SYMBOL_P (a)) \ + ? (lisp_h_XONLY_SYMBOL (a)) \ + : lisp_h_XONLY_SYMBOL (lisp_h_XLOCATED_SYMBOL (a)->sym))) + # define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK)) #endif @@ -462,6 +628,7 @@ typedef EMACS_INT Lisp_Word; # define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym) # define SYMBOL_TRAPPED_WRITE_P(sym) lisp_h_SYMBOL_TRAPPED_WRITE_P (sym) # define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym) +# define ONLY_SYMBOL_P(x) lisp_h_ONLY_SYMBOL_P (x) # define SYMBOLP(x) lisp_h_SYMBOLP (x) # define TAGGEDP(a, tag) lisp_h_TAGGEDP (a, tag) # define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x) @@ -476,6 +643,7 @@ typedef EMACS_INT Lisp_Word; # define make_fixnum(n) lisp_h_make_fixnum (n) # define XFIXNAT(a) lisp_h_XFIXNAT (a) # define XFIXNUM(a) lisp_h_XFIXNUM (a) +# define XONLY_SYMBOL(a) lisp_h_XONLY_SYMBOL (a) # define XSYMBOL(a) lisp_h_XSYMBOL (a) # define XTYPE(a) lisp_h_XTYPE (a) # endif @@ -585,24 +753,6 @@ enum Lisp_Fwd_Type You also need to add the new type to the constant `cl--typeof-types' in lisp/emacs-lisp/cl-preloaded.el. */ - -/* A Lisp_Object is a tagged pointer or integer. Ordinarily it is a - Lisp_Word. However, if CHECK_LISP_OBJECT_TYPE, it is a wrapper - around Lisp_Word, to help catch thinkos like 'Lisp_Object x = 0;'. - - LISP_INITIALLY (W) initializes a Lisp object with a tagged value - that is a Lisp_Word W. It can be used in a static initializer. */ - -#ifdef CHECK_LISP_OBJECT_TYPE -typedef struct Lisp_Object { Lisp_Word i; } Lisp_Object; -# define LISP_INITIALLY(w) {w} -# undef CHECK_LISP_OBJECT_TYPE -enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true }; -#else -typedef Lisp_Word Lisp_Object; -# define LISP_INITIALLY(w) (w) -enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = false }; -#endif /* Forward declarations. */ @@ -621,7 +771,7 @@ extern void char_table_set (Lisp_Object, int, Lisp_Object); /* Defined in data.c. */ extern _Noreturn void wrong_type_argument (Lisp_Object, Lisp_Object); - +extern Lisp_Object Vlocated_symbols_enabled; #ifdef CANNOT_DUMP enum { might_dump = false }; @@ -864,38 +1014,11 @@ typedef EMACS_UINT Lisp_Word_tag; #include "globals.h" -/* Header of vector-like objects. This documents the layout constraints on - vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents - compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR - and PSEUDOVECTORP cast their pointers to union vectorlike_header *, - because when two such pointers potentially alias, a compiler won't - incorrectly reorder loads and stores to their size fields. See - Bug#8546. This union formerly contained more members, and there's - no compelling reason to change it to a struct merely because the - number of members has been reduced to one. */ -union vectorlike_header - { - /* The main member contains various pieces of information: - - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit. - - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain - vector (0) or a pseudovector (1). - - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number - of slots) of the vector. - - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields: - - a) pseudovector subtype held in PVEC_TYPE_MASK field; - - b) number of Lisp_Objects slots at the beginning of the object - held in PSEUDOVECTOR_SIZE_MASK field. These objects are always - traced by the GC; - - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and - measured in word_size units. Rest fields may also include - Lisp_Objects, but these objects usually needs some special treatment - during GC. - There are some exceptions. For PVEC_FREE, b) is always zero. For - PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero. - Current layout limits the pseudovectors to 63 PVEC_xxx subtypes, - 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */ - ptrdiff_t size; - }; +INLINE bool +(LOCATED_SYMBOL_P) (Lisp_Object x) +{ + return lisp_h_LOCATED_SYMBOL_P (x); +} INLINE bool (SYMBOLP) (Lisp_Object x) @@ -954,89 +1077,7 @@ INLINE void lisp_h_CHECK_SYMBOL (x); } -/* In the size word of a vector, this bit means the vector has been marked. */ - -DEFINE_GDB_SYMBOL_BEGIN (ptrdiff_t, ARRAY_MARK_FLAG) -# define ARRAY_MARK_FLAG PTRDIFF_MIN -DEFINE_GDB_SYMBOL_END (ARRAY_MARK_FLAG) - -/* In the size word of a struct Lisp_Vector, this bit means it's really - some other vector-like object. */ -DEFINE_GDB_SYMBOL_BEGIN (ptrdiff_t, PSEUDOVECTOR_FLAG) -# define PSEUDOVECTOR_FLAG (PTRDIFF_MAX - PTRDIFF_MAX / 2) -DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG) - -/* In a pseudovector, the size field actually contains a word with one - PSEUDOVECTOR_FLAG bit set, and one of the following values extracted - with PVEC_TYPE_MASK to indicate the actual type. */ -enum pvec_type -{ - PVEC_NORMAL_VECTOR, - PVEC_FREE, - PVEC_BIGNUM, - PVEC_MARKER, - PVEC_OVERLAY, - PVEC_FINALIZER, - PVEC_MISC_PTR, -#ifdef HAVE_MODULES - PVEC_USER_PTR, -#endif - PVEC_PROCESS, - PVEC_FRAME, - PVEC_WINDOW, - PVEC_BOOL_VECTOR, - PVEC_BUFFER, - PVEC_HASH_TABLE, - PVEC_TERMINAL, - PVEC_WINDOW_CONFIGURATION, - PVEC_SUBR, - PVEC_OTHER, /* Should never be visible to Elisp code. */ - PVEC_XWIDGET, - PVEC_XWIDGET_VIEW, - PVEC_THREAD, - PVEC_MUTEX, - PVEC_CONDVAR, - PVEC_MODULE_FUNCTION, - - /* These should be last, check internal_equal to see why. */ - PVEC_COMPILED, - PVEC_CHAR_TABLE, - PVEC_SUB_CHAR_TABLE, - PVEC_RECORD, - PVEC_FONT /* Should be last because it's used for range checking. */ -}; - -enum More_Lisp_Bits - { - /* For convenience, we also store the number of elements in these bits. - Note that this size is not necessarily the memory-footprint size, but - only the number of Lisp_Object fields (that need to be traced by GC). - The distinction is used, e.g., by Lisp_Process, which places extra - non-Lisp_Object fields at the end of the structure. */ - PSEUDOVECTOR_SIZE_BITS = 12, - PSEUDOVECTOR_SIZE_MASK = (1 << PSEUDOVECTOR_SIZE_BITS) - 1, - - /* To calculate the memory footprint of the pseudovector, it's useful - to store the size of non-Lisp area in word_size units here. */ - PSEUDOVECTOR_REST_BITS = 12, - PSEUDOVECTOR_REST_MASK = (((1 << PSEUDOVECTOR_REST_BITS) - 1) - << PSEUDOVECTOR_SIZE_BITS), - - /* Used to extract pseudovector subtype information. */ - PSEUDOVECTOR_AREA_BITS = PSEUDOVECTOR_SIZE_BITS + PSEUDOVECTOR_REST_BITS, - PVEC_TYPE_MASK = 0x3f << PSEUDOVECTOR_AREA_BITS - }; -/* These functions extract various sorts of values from a Lisp_Object. - For example, if tem is a Lisp_Object whose type is Lisp_Cons, - XCONS (tem) is the struct Lisp_Cons * pointing to the memory for - that cons. */ - -/* Largest and smallest representable fixnum values. These are the C - values. They are macros for use in #if and static initializers. */ -#define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS) -#define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM) - #if USE_LSB_TAG INLINE Lisp_Object @@ -1586,6 +1627,7 @@ PSEUDOVECTOR_TYPEP (union vectorlike_header *a, enum pvec_type code) == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))); } +/* FIXME!!! 2018-11-09. Consider using lisp_h_PSEUDOVECTOR here. */ /* True if A is a pseudovector whose code is CODE. */ INLINE bool PSEUDOVECTORP (Lisp_Object a, int code) @@ -2480,6 +2522,29 @@ XOVERLAY (Lisp_Object a) return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay); } +INLINE struct Lisp_Located_Symbol * +XLOCATED_SYMBOL (Lisp_Object a) +{ + eassert (LOCATED_SYMBOL_P (a)); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Located_Symbol); +} + +INLINE Lisp_Object +LOCATED_SYMBOL_SYM (Lisp_Object a) +{ + if (!LOCATED_SYMBOL_P (a)) + wrong_type_argument (Qlocated_symbol_p, a); + return XLOCATED_SYMBOL (a)->sym; +} + +INLINE Lisp_Object +LOCATED_SYMBOL_LOC (Lisp_Object a) +{ + if (!LOCATED_SYMBOL_P (a)) + wrong_type_argument (Qlocated_symbol_p, a); + return XLOCATED_SYMBOL (a)->loc; +} + #ifdef HAVE_MODULES INLINE bool USER_PTRP (Lisp_Object x) @@ -3754,6 +3819,7 @@ extern bool gc_in_progress; extern Lisp_Object make_float (double); extern void display_malloc_warning (void); extern ptrdiff_t inhibit_garbage_collection (void); +extern Lisp_Object build_located_symbol (Lisp_Object, Lisp_Object); extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object); extern void free_cons (struct Lisp_Cons *); extern void init_alloc_once (void); diff --git a/src/lread.c b/src/lread.c index 5f3871436df..3490d83ecaf 100644 --- a/src/lread.c +++ b/src/lread.c @@ -616,12 +616,12 @@ struct subst }; static Lisp_Object read_internal_start (Lisp_Object, Lisp_Object, - Lisp_Object); -static Lisp_Object read0 (Lisp_Object); -static Lisp_Object read1 (Lisp_Object, int *, bool); + Lisp_Object, bool); +static Lisp_Object read0 (Lisp_Object, bool); +static Lisp_Object read1 (Lisp_Object, int *, bool, bool); -static Lisp_Object read_list (bool, Lisp_Object); -static Lisp_Object read_vector (Lisp_Object, bool); +static Lisp_Object read_list (bool, Lisp_Object, bool); +static Lisp_Object read_vector (Lisp_Object, bool, bool); static Lisp_Object substitute_object_recurse (struct subst *, Lisp_Object); static void substitute_in_interval (INTERVAL, void *); @@ -2046,7 +2046,7 @@ readevalloop (Lisp_Object readcharfun, Qnil, false); if (!NILP (Vpurify_flag) && c == '(') { - val = read_list (0, readcharfun); + val = read_list (0, readcharfun, false); } else { @@ -2068,7 +2068,7 @@ readevalloop (Lisp_Object readcharfun, else if (! NILP (Vload_read_function)) val = call1 (Vload_read_function, readcharfun); else - val = read_internal_start (readcharfun, Qnil, Qnil); + val = read_internal_start (readcharfun, Qnil, Qnil, false); } /* Empty hashes can be reused; otherwise, reset on next call. */ if (HASH_TABLE_P (read_objects_map) @@ -2217,7 +2217,35 @@ STREAM or the value of `standard-input' may be: return call1 (intern ("read-minibuffer"), build_string ("Lisp expression: ")); - return read_internal_start (stream, Qnil, Qnil); + return read_internal_start (stream, Qnil, Qnil, false); +} + +DEFUN ("read-locating-symbols", Fread_locating_symbols, + Sread_locating_symbols, 0, 1, 0, + doc: /* Read one Lisp expression as text from STREAM, return as Lisp object. +Convert each occurrence of a symbol into a "located symbol" object. + +If STREAM is nil, use the value of `standard-input' (which see). +STREAM or the value of `standard-input' may be: + a buffer (read from point and advance it) + a marker (read from where it points and advance it) + a function (call it with no arguments for each character, + call it with a char as argument to push a char back) + a string (takes text from string, starting at the beginning) + t (read text line using minibuffer and use it, or read from + standard input in batch mode). */) + (Lisp_Object stream) +{ + if (NILP (stream)) + stream = Vstandard_input; + if (EQ (stream, Qt)) + stream = Qread_char; + if (EQ (stream, Qread_char)) + /* FIXME: ?! When is this used !? */ + return call1 (intern ("read-minibuffer"), + build_string ("Lisp expression: ")); + + return read_internal_start (stream, Qnil, Qnil, true); } DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0, @@ -2233,14 +2261,17 @@ the end of STRING. */) Lisp_Object ret; CHECK_STRING (string); /* `read_internal_start' sets `read_from_string_index'. */ - ret = read_internal_start (string, start, end); + ret = read_internal_start (string, start, end, false); return Fcons (ret, make_fixnum (read_from_string_index)); } /* Function to set up the global context we need in toplevel read - calls. START and END only used when STREAM is a string. */ + calls. START and END only used when STREAM is a string. + LOCATE_SYMS true means read symbol occurrences as located + symbols. */ static Lisp_Object -read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) +read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end, + bool locate_syms) { Lisp_Object retval; @@ -2281,7 +2312,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) read_from_string_limit = endval; } - retval = read0 (stream); + retval = read0 (stream, locate_syms); if (EQ (Vread_with_symbol_positions, Qt) || EQ (Vread_with_symbol_positions, stream)) Vread_symbol_positions_list = Fnreverse (Vread_symbol_positions_list); @@ -2310,12 +2341,12 @@ invalid_syntax (const char *s) are not allowed. */ static Lisp_Object -read0 (Lisp_Object readcharfun) +read0 (Lisp_Object readcharfun, bool locate_syms) { register Lisp_Object val; int c; - val = read1 (readcharfun, &c, 0); + val = read1 (readcharfun, &c, 0, locate_syms); if (!c) return val; @@ -2736,10 +2767,11 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix) in *PCH and the return value is not interesting. Else, we store zero in *PCH and we read and return one lisp object. - FIRST_IN_LIST is true if this is the first element of a list. */ + FIRST_IN_LIST is true if this is the first element of a list. + LOCATE_SYMS true means read symbol occurrences as located symbols. */ static Lisp_Object -read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) +read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms) { int c; bool uninterned_symbol = false; @@ -2758,10 +2790,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) switch (c) { case '(': - return read_list (0, readcharfun); + return read_list (0, readcharfun, locate_syms); case '[': - return read_vector (readcharfun, 0); + return read_vector (readcharfun, 0, locate_syms); case ')': case ']': @@ -2780,7 +2812,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) /* Accept extended format for hash tables (extensible to other types), e.g. #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */ - Lisp_Object tmp = read_list (0, readcharfun); + Lisp_Object tmp = read_list (0, readcharfun, locate_syms); Lisp_Object head = CAR_SAFE (tmp); Lisp_Object data = Qnil; Lisp_Object val = Qnil; @@ -2866,7 +2898,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (c == '[') { Lisp_Object tmp; - tmp = read_vector (readcharfun, 0); + tmp = read_vector (readcharfun, 0, locate_syms); if (ASIZE (tmp) < CHAR_TABLE_STANDARD_SLOTS) error ("Invalid size char-table"); XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE); @@ -2879,7 +2911,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) { /* Sub char-table can't be read as a regular vector because of a two C integer fields. */ - Lisp_Object tbl, tmp = read_list (1, readcharfun); + Lisp_Object tbl, tmp = read_list (1, readcharfun, locate_syms); ptrdiff_t size = XFIXNUM (Flength (tmp)); int i, depth, min_char; struct Lisp_Cons *cell; @@ -2917,7 +2949,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (c == '&') { Lisp_Object length; - length = read1 (readcharfun, pch, first_in_list); + length = read1 (readcharfun, pch, first_in_list, locate_syms); c = READCHAR; if (c == '"') { @@ -2926,7 +2958,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) unsigned char *data; UNREAD (c); - tmp = read1 (readcharfun, pch, first_in_list); + tmp = read1 (readcharfun, pch, first_in_list, locate_syms); if (STRING_MULTIBYTE (tmp) || (size_in_chars != SCHARS (tmp) /* We used to print 1 char too many @@ -2954,7 +2986,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) build them using function calls. */ Lisp_Object tmp; struct Lisp_Vector *vec; - tmp = read_vector (readcharfun, 1); + tmp = read_vector (readcharfun, 1, locate_syms); vec = XVECTOR (tmp); if (vec->header.size == 0) invalid_syntax ("Empty byte-code object"); @@ -2967,7 +2999,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) int ch; /* Read the string itself. */ - tmp = read1 (readcharfun, &ch, 0); + tmp = read1 (readcharfun, &ch, 0, locate_syms); if (ch != 0 || !STRINGP (tmp)) invalid_syntax ("#"); /* Read the intervals and their properties. */ @@ -2975,14 +3007,14 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) { Lisp_Object beg, end, plist; - beg = read1 (readcharfun, &ch, 0); + beg = read1 (readcharfun, &ch, 0, locate_syms); end = plist = Qnil; if (ch == ')') break; if (ch == 0) - end = read1 (readcharfun, &ch, 0); + end = read1 (readcharfun, &ch, 0, locate_syms); if (ch == 0) - plist = read1 (readcharfun, &ch, 0); + plist = read1 (readcharfun, &ch, 0, locate_syms); if (ch) invalid_syntax ("Invalid string property list"); Fset_text_properties (beg, end, plist, tmp); @@ -3093,7 +3125,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (c == '$') return Vload_file_name; if (c == '\'') - return list2 (Qfunction, read0 (readcharfun)); + return list2 (Qfunction, read0 (readcharfun, locate_syms)); /* #:foo is the uninterned symbol named foo. */ if (c == ':') { @@ -3166,7 +3198,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) hash_put (h, number, placeholder, hash); /* Read the object itself. */ - tem = read0 (readcharfun); + tem = read0 (readcharfun, locate_syms); /* If it can be recursive, remember it for future substitutions. */ @@ -3230,7 +3262,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) goto retry; case '\'': - return list2 (Qquote, read0 (readcharfun)); + return list2 (Qquote, read0 (readcharfun, locate_syms)); case '`': { @@ -3254,7 +3286,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) bool saved_new_backquote_flag = new_backquote_flag; new_backquote_flag = 1; - value = read0 (readcharfun); + value = read0 (readcharfun, locate_syms); new_backquote_flag = saved_new_backquote_flag; return list2 (Qbackquote, value); @@ -3294,7 +3326,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) comma_type = Qcomma; } - value = read0 (readcharfun); + value = read0 (readcharfun, locate_syms); return list2 (comma_type, value); } else @@ -3586,6 +3618,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) result = intern_driver (name, obarray, tem); } } + if (locate_syms) + result = build_located_symbol (result, + make_fixnum (start_position)); if (EQ (Vread_with_symbol_positions, Qt) || EQ (Vread_with_symbol_positions, readcharfun)) @@ -3844,7 +3879,7 @@ string_to_number (char const *string, int base, ptrdiff_t *plen) static Lisp_Object -read_vector (Lisp_Object readcharfun, bool bytecodeflag) +read_vector (Lisp_Object readcharfun, bool bytecodeflag, bool locate_syms) { ptrdiff_t i, size; Lisp_Object *ptr; @@ -3852,7 +3887,7 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag) struct Lisp_Cons *otem; Lisp_Object len; - tem = read_list (1, readcharfun); + tem = read_list (1, readcharfun, locate_syms); len = Flength (tem); if (bytecodeflag && XFIXNAT (len) <= COMPILED_STACK_DEPTH) error ("Invalid byte code"); @@ -3923,10 +3958,12 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag) return vector; } -/* FLAG means check for ']' to terminate rather than ')' and '.'. */ +/* FLAG means check for ']' to terminate rather than ')' and '.'. + LOCATE_SYMS true means read symbol occurrencess as located + symbols. */ static Lisp_Object -read_list (bool flag, Lisp_Object readcharfun) +read_list (bool flag, Lisp_Object readcharfun, bool locate_syms) { Lisp_Object val, tail; Lisp_Object elt, tem; @@ -3944,7 +3981,7 @@ read_list (bool flag, Lisp_Object readcharfun) while (1) { int ch; - elt = read1 (readcharfun, &ch, first_in_list); + elt = read1 (readcharfun, &ch, first_in_list, locate_syms); first_in_list = 0; @@ -3988,10 +4025,10 @@ read_list (bool flag, Lisp_Object readcharfun) if (ch == '.') { if (!NILP (tail)) - XSETCDR (tail, read0 (readcharfun)); + XSETCDR (tail, read0 (readcharfun, locate_syms)); else - val = read0 (readcharfun); - read1 (readcharfun, &ch, 0); + val = read0 (readcharfun, locate_syms); + read1 (readcharfun, &ch, 0, locate_syms); if (ch == ')') { @@ -4808,6 +4845,7 @@ void syms_of_lread (void) { defsubr (&Sread); + defsubr (&Sread_locating_symbols); defsubr (&Sread_from_string); defsubr (&Slread__substitute_object_in_subtree); defsubr (&Sintern); @@ -4984,6 +5022,7 @@ Called with a single argument (the stream from which to read). The default is to use the function `read'. */); DEFSYM (Qread, "read"); Vload_read_function = Qread; + DEFSYM (Qread_locating_symbols, "read-locating-symbols"); DEFVAR_LISP ("load-source-file-function", Vload_source_file_function, doc: /* Function called in `load' to load an Emacs Lisp source file. diff --git a/src/print.c b/src/print.c index d15ff97b00c..d1388062a12 100644 --- a/src/print.c +++ b/src/print.c @@ -1394,6 +1394,25 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, printchar ('>', printcharfun); break; + case PVEC_LOCATED_SYMBOL: + { + struct Lisp_Located_Symbol *ls = XLOCATED_SYMBOL (obj); + print_c_string ("#sym)) + print_object (ls->sym, printcharfun, escapeflag); + else + print_c_string ("NOT A SYMBOL!!", printcharfun); + if (FIXNUMP (ls->loc)) + { + print_c_string (" at ", printcharfun); + print_object (ls->loc, printcharfun, escapeflag); + } + else + print_c_string (" NOT A LOCATION!!", printcharfun); + printchar ('>', printcharfun); + } + break; + case PVEC_OVERLAY: print_c_string ("#buffer)