[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] scratch/accurate-warning-pos 580e663: First draught of cre
|
From: |
Alan Mackenzie |
|
Subject: |
[Emacs-diffs] scratch/accurate-warning-pos 580e663: First draught of creation of "located symbols". |
|
Date: |
Sun, 11 Nov 2018 07:09:54 -0500 (EST) |
branch: scratch/accurate-warning-pos
commit 580e66335a52222fb95ef3564a6480357ef5326f
Author: Alan Mackenzie <address@hidden>
Commit: Alan Mackenzie <address@hidden>
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.
---
src/alloc.c | 15 +++
src/data.c | 49 +++++++++
src/fns.c | 7 ++
src/lisp.h | 342 ++++++++++++++++++++++++++++++++++++------------------------
src/lread.c | 121 +++++++++++++--------
src/print.c | 19 ++++
6 files changed, 374 insertions(+), 179 deletions(-)
diff --git a/src/alloc.c b/src/alloc.c
index 0e48b33..7961fc1 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 538081e..768d87b 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 c9a6dd6..d421bc4 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 eb67626..b4fc6f2 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 5f38714..3490d83 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 d15ff97..d138806 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 ("#<symbol ", printcharfun);
+ if (SYMBOLP (ls->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 ("#<overlay ", printcharfun);
if (! XMARKER (OVERLAY_START (obj))->buffer)