procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'scratch/correct-warning-pos'

Browse source
This commit is contained in:
Alan Mackenzie 2022-01-22 17:41:03 +00:00
commit 88e1f8b020
30 changed files with 1521 additions and 663 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
doc/lispref/elisp.texi
View file

@ -448,6 +448,9 @@ Symbols
* Creating Symbols:: How symbols are kept unique.
* Symbol Properties:: Each symbol has a property list
for recording miscellaneous information.
* Shorthands:: Properly organize your symbol names but
type less of them.
* Symbols with Position:: Symbol variants containing integer positions
Symbol Properties

10
doc/lispref/streams.texi
View file

@ -326,6 +326,16 @@ For example:
@end group
@end example
@end defun
@end defun
@defun read-positioning-symbols &optional stream
This function reads one textual expression from @var{stream}, like
@code{read} does, but additionally positions the read symbols to the
positions in @var{stream} where they occurred. Only the symbol
@code{nil} is not positioned, this for efficiency reasons.
@xref{Symbols with Position}. This function is used by the byte
compiler.
@end defun
@defvar standard-input
This variable holds the default input stream---the stream that

82
doc/lispref/symbols.texi
View file

@ -23,15 +23,15 @@ otherwise.
@end defun
@menu
* Symbol Components:: Symbols have names, values, function definitions
* Symbol Components:: Symbols have names, values, function definitions
and property lists.
* Definitions:: A definition says how a symbol will be used.
* Creating Symbols:: How symbols are kept unique.
* Symbol Properties:: Each symbol has a property list
* Definitions:: A definition says how a symbol will be used.
* Creating Symbols:: How symbols are kept unique.
* Symbol Properties:: Each symbol has a property list
for recording miscellaneous information.
* Shorthands:: Properly organize your symbol names but
* Shorthands:: Properly organize your symbol names but
type less of them.
* Symbols with Position:: Symbol variants containing integer positions
@end menu
@node Symbol Components
@ -432,8 +432,8 @@ symbol's property list cell (@pxref{Symbol Components}), in the form
of a property list (@pxref{Property Lists}).
@menu
* Symbol Plists:: Accessing symbol properties.
* Standard Properties:: Standard meanings of symbol properties.
* Symbol Plists:: Accessing symbol properties.
* Standard Properties:: Standard meanings of symbol properties.
@end menu
@node Symbol Plists
@ -751,3 +751,69 @@ those names.
@item
Symbol forms whose names start with @samp{#_} are not transformed.
@end itemize
@node Symbols with Position
@section Symbols with Position
@cindex symbols with position
A @dfn{symbol with position} is a symbol, the @dfn{bare symbol},
together with an unsigned integer called the @dfn{position}. These
objects are intended for use by the byte compiler, which records in
them the position of each symbol occurrence and uses those positions
in warning and error messages.
The printed representation of a symbol with position uses the hash
notation outlined in @ref{Printed Representation}. It looks like
@samp{#<symbol foo at 12345>}. It has no read syntax. You can cause
just the bare symbol to be printed by binding the variable
@code{print-symbols-bare} to non-@code{nil} around the print
operation. The byte compiler does this before writing its output to
the compiled Lisp file.
For most purposes, when the flag variable
@code{symbols-with-pos-enabled} is non-@code{nil}, symbols with
positions behave just as bare symbols do. For example, @samp{(eq
#<symbol foo at 12345> foo)} has a value @code{t} when that variable
is set (but nil when it isn't set). Most of the time in Emacs this
variable is @code{nil}, but the byte compiler binds it to @code{t}
when it runs.
Typically, symbols with position are created by the byte compiler
calling the reader function @code{read-positioning-symbols}
(@pxref{Input Functions}). One can also be created with the function
@code{position-symbol}.
@defvar symbols-with-pos-enabled
When this variable is non-@code{nil}, symbols with position behave
like the contained bare symbol. Emacs runs a little more slowly in
this case.
@end defvar
@defvar print-symbols-bare
When bound to non-nil, the Lisp printer prints only the bare symbol of
a symbol with position, ignoring the position.
@end defvar
@defun symbol-with-pos-p symbol.
This function returns @code{t} if @var{symbol} is a symbol with
position, @code{nil} otherwise.
@end defun
@defun bare-symbol symbol
This function returns the bare symbol contained in @var{symbol}, or
@var{symbol} itself if it is already a bare symbol. For any other
type of object, it throws an error.
@end defun
@defun symbol-with-pos-pos symbol
This function returns the position, a number, from a symbol with
position. For any other type of object, it throws an error.
@end defun
@defun position-symbol sym pos
Make a new symbol with position. @var{sym} is either a bare symbol or
a symbol with position, and supplies the symbol part of the new
object. @var{pos} is either an integer which becomes the number part
of the new object, or a symbol with position whose position is used.
Emacs throws an error if either argument is invalid.
@end defun

32
lisp/cedet/semantic/fw.el
View file

@ -191,12 +191,20 @@ will throw a warning when it encounters this symbol."
(not (string-match "cedet" (macroexp-file-name)))
)
(make-obsolete-overload oldfnalias newfn when)
(byte-compile-warn
"%s: `%s' obsoletes overload `%s'"
(macroexp-file-name)
newfn
(with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function))
(semantic-overload-symbol-from-function oldfnalias)))))
(if (fboundp 'byte-compile-warn-x)
(byte-compile-warn-x
newfn
"%s: `%s' obsoletes overload `%s'"
(macroexp-file-name)
newfn
(with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function))
(semantic-overload-symbol-from-function oldfnalias)))
(byte-compile-warn
"%s: `%s' obsoletes overload `%s'"
(macroexp-file-name)
newfn
(with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function))
(semantic-overload-symbol-from-function oldfnalias))))))
(defun semantic-varalias-obsolete (oldvaralias newvar when)
"Make OLDVARALIAS an alias for variable NEWVAR.
@ -209,10 +217,14 @@ will throw a warning when it encounters this symbol."
(error
;; Only throw this warning when byte compiling things.
(when (macroexp-compiling-p)
(byte-compile-warn
"variable `%s' obsoletes, but isn't alias of `%s'"
newvar oldvaralias)
))))
(if (fboundp 'byte-compile-warn-x)
(byte-compile-warn-x
newvar
"variable `%s' obsoletes, but isn't alias of `%s'"
newvar oldvaralias)
(byte-compile-warn
"variable `%s' obsoletes, but isn't alias of `%s'"
newvar oldvaralias))))))
;;; Help debugging
;;

1
lisp/emacs-lisp/bindat.el
View file

@ -804,6 +804,7 @@ is the name of a variable that will hold the value we need to pack.")
(if (or (eq label '_) (not (assq label labels)))
code
(macroexp-warn-and-return
code
(format "Duplicate label: %S" label)
code))))
(`(,_ ,val)

38
lisp/emacs-lisp/byte-opt.el
View file

@ -264,8 +264,9 @@ Earlier variables shadow later ones with the same name.")
(cdr (assq name byte-compile-function-environment)))))
(pcase fn
('nil
(byte-compile-warn "attempt to inline `%s' before it was defined"
name)
(byte-compile-warn-x name
"attempt to inline `%s' before it was defined"
name)
form)
(`(autoload . ,_)
(error "File `%s' didn't define `%s'" (nth 1 fn) name))
@ -421,8 +422,8 @@ for speeding up processing.")
(t form)))
(`(quote . ,v)
(if (or (not v) (cdr v))
(byte-compile-warn "malformed quote form: `%s'"
(prin1-to-string form)))
(byte-compile-warn-x form "malformed quote form: `%s'"
form))
;; Map (quote nil) to nil to simplify optimizer logic.
;; Map quoted constants to nil if for-effect (just because).
(and (car v)
@ -440,8 +441,9 @@ for speeding up processing.")
(cons
(byte-optimize-form (car clause) nil)
(byte-optimize-body (cdr clause) for-effect))
(byte-compile-warn "malformed cond form: `%s'"
(prin1-to-string clause))
(byte-compile-warn-x
clause "malformed cond form: `%s'"
clause)
clause))
clauses)))
(`(progn . ,exps)
@ -517,8 +519,7 @@ for speeding up processing.")
`(while ,condition . ,body)))
(`(interactive . ,_)
(byte-compile-warn "misplaced interactive spec: `%s'"
(prin1-to-string form))
(byte-compile-warn-x form "misplaced interactive spec: `%s'" form)
nil)
(`(function . ,_)
@ -586,7 +587,7 @@ for speeding up processing.")
(while args
(unless (and (consp args)
(symbolp (car args)) (consp (cdr args)))
(byte-compile-warn "malformed setq form: %S" form))
(byte-compile-warn-x form "malformed setq form: %S" form))
(let* ((var (car args))
(expr (cadr args))
(lexvar (assq var byte-optimize--lexvars))
@ -619,8 +620,7 @@ for speeding up processing.")
(cons fn (mapcar #'byte-optimize-form exps)))
(`(,(pred (not symbolp)) . ,_)
(byte-compile-warn "`%s' is a malformed function"
(prin1-to-string fn))
(byte-compile-warn-x fn "`%s' is a malformed function" fn)
form)
((guard (when for-effect
@ -628,8 +628,10 @@ for speeding up processing.")
(or byte-compile-delete-errors
(eq tmp 'error-free)
(progn
(byte-compile-warn "value returned from %s is unused"
(prin1-to-string form))
(byte-compile-warn-x
form
"value returned from %s is unused"
form)
nil)))))
(byte-compile-log " %s called for effect; deleted" fn)
;; appending a nil here might not be necessary, but it can't hurt.
@ -825,7 +827,8 @@ for speeding up processing.")
(if (symbolp binding)
binding
(when (or (atom binding) (cddr binding))
(byte-compile-warn "malformed let binding: `%S'" binding))
(byte-compile-warn-x
binding "malformed let binding: `%S'" binding))
(list (car binding)
(byte-optimize-form (nth 1 binding) nil))))
(car form))
@ -1308,7 +1311,7 @@ See Info node `(elisp) Integer Basics'."
(defun byte-optimize-while (form)
(when (< (length form) 2)
(byte-compile-warn "too few arguments for `while'"))
(byte-compile-warn-x form "too few arguments for `while'"))
(if (nth 1 form)
form))
@ -1346,9 +1349,10 @@ See Info node `(elisp) Integer Basics'."
(let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
(nconc (list 'funcall fn) butlast
(mapcar (lambda (x) (list 'quote x)) (nth 1 last))))
(byte-compile-warn
(byte-compile-warn-x
last
"last arg to apply can't be a literal atom: `%s'"
(prin1-to-string last))
last)
nil))
form))))

85
lisp/emacs-lisp/byte-run.el
View file

@ -30,6 +30,83 @@
;;; Code:
(defvar byte-run--ssp-seen nil
"Which conses/vectors/records have been processed in strip-symbol-positions?
The value is a hash table, the key being the old element and the value being
the corresponding new element of the same type.
The purpose of this is to detect circular structures.")
(defalias 'byte-run--circular-list-p
#'(lambda (l)
"Return non-nil when the list L is a circular list.
Note that this algorithm doesn't check any circularity in the
CARs of list elements."
(let ((hare l)
(tortoise l))
(condition-case err
(progn
(while (progn
(setq hare (cdr (cdr hare))
tortoise (cdr tortoise))
(not (or (eq tortoise hare)
(null hare)))))
(eq tortoise hare))
(wrong-type-argument nil)
(error (signal (car err) (cdr err)))))))
(defalias 'byte-run--strip-s-p-1
#'(lambda (arg)
"Strip all positions from symbols in ARG, modifying ARG.
Return the modified ARG."
(cond
((symbol-with-pos-p arg)
(bare-symbol arg))
((consp arg)
(let* ((round (byte-run--circular-list-p arg))
(hash (and round (gethash arg byte-run--ssp-seen))))
(or hash
(let ((a arg) new)
(while
(progn
(when round
(puthash a new byte-run--ssp-seen))
(setq new (byte-run--strip-s-p-1 (car a)))
(when (not (eq new (car a))) ; For read-only things.
(setcar a new))
(and (consp (cdr a))
(not
(setq hash
(and round
(gethash (cdr a) byte-run--ssp-seen))))))
(setq a (cdr a)))
(setq new (byte-run--strip-s-p-1 (cdr a)))
(when (not (eq new (cdr a)))
(setcdr a (or hash new)))
arg))))
((or (vectorp arg) (recordp arg))
(let ((hash (gethash arg byte-run--ssp-seen)))
(or hash
(let* ((len (length arg))
(i 0)
new)
(puthash arg arg byte-run--ssp-seen)
(while (< i len)
(setq new (byte-run--strip-s-p-1 (aref arg i)))
(when (not (eq new (aref arg i)))
(aset arg i new))
(setq i (1+ i)))
arg))))
(t arg))))
(defalias 'byte-run-strip-symbol-positions
#'(lambda (arg)
(setq byte-run--ssp-seen (make-hash-table :test 'eq))
(byte-run--strip-s-p-1 arg)))
(defalias 'function-put
;; We don't want people to just use `put' because we can't conveniently
;; hook into `put' to remap old properties to new ones. But for now, there's
@ -38,7 +115,9 @@
"Set FUNCTION's property PROP to VALUE.
The namespace for PROP is shared with symbols.
So far, FUNCTION can only be a symbol, not a lambda expression."
(put function prop value)))
(put (bare-symbol function)
(byte-run-strip-symbol-positions prop)
(byte-run-strip-symbol-positions value))))
(function-put 'defmacro 'doc-string-elt 3)
(function-put 'defmacro 'lisp-indent-function 2)
@ -254,7 +333,8 @@ The return value is undefined.
#'(lambda (x)
(let ((f (cdr (assq (car x) macro-declarations-alist))))
(if f (apply (car f) name arglist (cdr x))
(macroexp-warn-and-return
(macroexp-warn-and-return
(car x)
(format-message
"Unknown macro property %S in %S"
(car x) name)
@ -328,6 +408,7 @@ The return value is undefined.
nil)
(t
(macroexp-warn-and-return
(car x)
(format-message "Unknown defun property `%S' in %S"
(car x) name)
nil)))))

613
lisp/emacs-lisp/bytecomp.el
View file

File diff suppressed because it is too large Load diff

41
lisp/emacs-lisp/cconv.el
View file

@ -258,11 +258,11 @@ Returns a form where all lambdas don't have any free variables."
;; unused vars.
(not (intern-soft var))
(eq ?_ (aref (symbol-name var) 0))
;; As a special exception, ignore "ignore".
;; As a special exception, ignore "ignored".
(eq var 'ignored))
(let ((suggestions (help-uni-confusable-suggestions (symbol-name var))))
(format "Unused lexical %s `%S'%s"
varkind var
varkind (bare-symbol var)
(if suggestions (concat "\n " suggestions) "")))))
(define-inline cconv--var-classification (binder form)
@ -286,7 +286,7 @@ of converted forms."
(let (and (pred stringp) msg)
(cconv--warn-unused-msg arg "argument")))
(if (assq arg env) (push `(,arg . nil) env)) ;FIXME: Is it needed?
(push (lambda (body) (macroexp--warn-wrap msg body 'lexical)) wrappers))
(push (lambda (body) (macroexp--warn-wrap body msg body 'lexical)) wrappers))
(_
(if (assq arg env) (push `(,arg . nil) env)))))
(setq funcbody (mapcar (lambda (form)
@ -367,7 +367,8 @@ places where they originally did not directly appear."
(var (if (not (consp binder))
(prog1 binder (setq binder (list binder)))
(when (cddr binder)
(byte-compile-warn
(byte-compile-warn-x
binder
"Malformed `%S' binding: %S"
letsym binder))
(setq value (cadr binder))
@ -375,9 +376,9 @@ places where they originally did not directly appear."
(cond
;; Ignore bindings without a valid name.
((not (symbolp var))
(byte-compile-warn "attempt to let-bind nonvariable `%S'" var))
(byte-compile-warn-x var "attempt to let-bind nonvariable `%S'" var))
((or (booleanp var) (keywordp var))
(byte-compile-warn "attempt to let-bind constant `%S'" var))
(byte-compile-warn-x var "attempt to let-bind constant `%S'" var))
(t
(let ((new-val
(pcase (cconv--var-classification binder form)
@ -427,11 +428,14 @@ places where they originally did not directly appear."
;; Declared variable is unused.
(if (assq var new-env)
(push `(,var) new-env)) ;FIXME:Needed?
(let ((newval
`(ignore ,(cconv-convert value env extend)))
(msg (cconv--warn-unused-msg var "variable")))
(let* ((Ignore (if (symbol-with-pos-p var)
(position-symbol 'ignore var)
'ignore))
(newval `(,Ignore
,(cconv-convert value env extend)))
(msg (cconv--warn-unused-msg var "variable")))
(if (null msg) newval
(macroexp--warn-wrap msg newval 'lexical))))
(macroexp--warn-wrap var msg newval 'lexical))))
;; Normal default case.
(_
@ -530,7 +534,7 @@ places where they originally did not directly appear."
(newprotform (cconv-convert protected-form env extend)))
`(condition-case ,var
,(if msg
(macroexp--warn-wrap msg newprotform 'lexical)
(macroexp--warn-wrap var msg newprotform 'lexical)
newprotform)
,@(mapcar
(lambda (handler)
@ -624,7 +628,8 @@ FORM is the parent form that binds this var."
;; FIXME: Convert this warning to use `macroexp--warn-wrap'
;; so as to give better position information.
(when (byte-compile-warning-enabled-p 'not-unused var)
(byte-compile-warn "%s `%S' not left unused" varkind var)))
(byte-compile-warn-x
var "%s `%S' not left unused" varkind var)))
((and (let (or 'let* 'let) (car form))
`((,var) ;; (or `(,var nil) : Too many false positives: bug#47080
t nil ,_ ,_))
@ -632,7 +637,7 @@ FORM is the parent form that binds this var."
;; so as to give better position information and obey
;; `byte-compile-warnings'.
(unless (not (intern-soft var))
(byte-compile-warn "Variable `%S' left uninitialized" var))))
(byte-compile-warn-x var "Variable `%S' left uninitialized" var))))
(pcase vardata
(`(,binder nil ,_ ,_ nil)
(push (cons (cons binder form) :unused) cconv-var-classification))
@ -661,7 +666,8 @@ FORM is the parent form that binds this var."
(dolist (arg args)
(cond
((byte-compile-not-lexical-var-p arg)
(byte-compile-warn
(byte-compile-warn-x
arg
"Lexical argument shadows the dynamic variable %S"
arg))
((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ...
@ -744,7 +750,8 @@ This function does not return anything but instead fills the
(setq forms (cddr forms))))
(`((lambda . ,_) . ,_) ; First element is lambda expression.
(byte-compile-warn
(byte-compile-warn-x
(nth 1 (car form))
"Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form)))
(dolist (exp `((function ,(car form)) . ,(cdr form)))
(cconv-analyze-form exp env)))
@ -763,8 +770,8 @@ This function does not return anything but instead fills the
(`(condition-case ,var ,protected-form . ,handlers)
(cconv-analyze-form protected-form env)
(when (and var (symbolp var) (byte-compile-not-lexical-var-p var))
(byte-compile-warn
"Lexical variable shadows the dynamic variable %S" var))
(byte-compile-warn-x
var "Lexical variable shadows the dynamic variable %S" var))
(let* ((varstruct (list var nil nil nil nil)))
(if var (push varstruct env))
(dolist (handler handlers)

4
lisp/emacs-lisp/cl-generic.el
View file

@ -498,7 +498,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
cl--generic-edebug-make-name nil]
lambda-doc ; documentation string
def-body))) ; part to be debugged
(let ((qualifiers nil))
(let ((qualifiers nil)
(org-name name))
(while (cl-generic--method-qualifier-p args)
(push args qualifiers)
(setq args (pop body)))
@ -513,6 +514,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
(byte-compile-warning-enabled-p 'obsolete name))
(let* ((obsolete (get name 'byte-obsolete-info)))
(macroexp-warn-and-return
org-name
(macroexp--obsolete-warning name obsolete "generic function")
nil)))
;; You could argue that `defmethod' modifies rather than defines the

12
lisp/emacs-lisp/cl-macs.el
View file

@ -2429,10 +2429,12 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
(append bindings venv))
macroexpand-all-environment))))
(if malformed-bindings
(macroexp-warn-and-return
(format-message "Malformed `cl-symbol-macrolet' binding(s): %S"
(nreverse malformed-bindings))
expansion)
(let ((rev-malformed-bindings (nreverse malformed-bindings)))
(macroexp-warn-and-return
rev-malformed-bindings
(format-message "Malformed `cl-symbol-macrolet' binding(s): %S"
rev-malformed-bindings)
expansion))
expansion)))
(unless advised
(advice-remove 'macroexpand #'cl--sm-macroexpand)))))
@ -3116,6 +3118,7 @@ To see the documentation for a defined struct type, use
(when (cl-oddp (length desc))
(push
(macroexp-warn-and-return
(car (last desc))
(format "Missing value for option `%S' of slot `%s' in struct %s!"
(car (last desc)) slot name)
'nil)
@ -3125,6 +3128,7 @@ To see the documentation for a defined struct type, use
(let ((kw (car defaults)))
(push
(macroexp-warn-and-return
kw
(format " I'll take `%s' to be an option rather than a default value."
kw)
'nil)

19
lisp/emacs-lisp/comp.el
View file

@ -1831,9 +1831,7 @@ and the annotation emission."
(byte-listp auto)
(byte-eq auto)
(byte-memq auto)
(byte-not
(comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp))
(make-comp-mvar :constant nil))))
(byte-not null)
(byte-car auto)
(byte-cdr auto)
(byte-cons auto)
@ -3570,7 +3568,7 @@ Update all insn accordingly."
;; Symbols imported by C inlined functions. We do this here because
;; is better to add all objs to the relocation containers before we
;; compacting them.
(mapc #'comp-add-const-to-relocs '(nil t consp listp))
(mapc #'comp-add-const-to-relocs '(nil t consp listp symbol-with-pos-p))
(let* ((d-default (comp-ctxt-d-default comp-ctxt))
(d-default-idx (comp-data-container-idx d-default))
@ -4006,9 +4004,12 @@ the deferred compilation mechanism."
(signal 'native-compiler-error
(list "Not a function symbol or file" function-or-file)))
(catch 'no-native-compile
(let* ((data function-or-file)
(let* ((print-symbols-bare t)
(max-specpdl-size (max max-specpdl-size 5000))
(data function-or-file)
(comp-native-compiling t)
(byte-native-qualities nil)
(symbols-with-pos-enabled t)
;; Have byte compiler signal an error when compilation fails.
(byte-compile-debug t)
(comp-ctxt (make-comp-ctxt :output output
@ -4052,10 +4053,10 @@ the deferred compilation mechanism."
(signal (car err) (if (consp err-val)
(cons function-or-file err-val)
(list function-or-file err-val)))))))
(if (stringp function-or-file)
data
;; So we return the compiled function.
(native-elisp-load data)))))
(if (stringp function-or-file)
data
;; So we return the compiled function.
(native-elisp-load data)))))
(defun native-compile-async-skip-p (file load selector)
"Return non-nil if FILE's compilation should be skipped.

1
lisp/emacs-lisp/easy-mmode.el
View file

@ -230,6 +230,7 @@ INIT-VALUE LIGHTER KEYMAP.
(warnwrap (if (or (null body) (keywordp (car body))) #'identity
(lambda (exp)
(macroexp-warn-and-return
exp
"Use keywords rather than deprecated positional arguments to `define-minor-mode'"
exp))))
keyw keymap-sym tmp)

5
lisp/emacs-lisp/eieio-core.el
View file

@ -748,6 +748,7 @@ Argument FN is the function calling this verifier."
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return
name
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only))
(_ exp))))
@ -784,11 +785,13 @@ Fills in CLASS's SLOT with its default value."
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return
name
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only))
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-class-slot-names))))
(macroexp-warn-and-return
name
(format-message "Slot `%S' is not class-allocated" name)
exp nil 'compile-only))
(_ exp)))))
@ -846,11 +849,13 @@ Fills in the default value in CLASS' in SLOT with VALUE."
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return
name
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only))
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-class-slot-names))))
(macroexp-warn-and-return
name
(format-message "Slot `%S' is not class-allocated" name)
exp nil 'compile-only))
(_ exp)))))

17
lisp/emacs-lisp/eieio.el
View file

@ -181,9 +181,11 @@ and reference them using the function `class-option'."
;; Is there an initarg, but allocation of class?
(when (and initarg (eq alloc :class))
(push (format "Meaningless :initarg for class allocated slot '%S'"
sname)
warnings))
(push
(cons sname
(format "Meaningless :initarg for class allocated slot '%S'"
sname))
warnings))
(let ((init (plist-get soptions :initform)))
(unless (or (macroexp-const-p init)
@ -194,8 +196,9 @@ and reference them using the function `class-option'."
;; heuristic says and if it disagrees with normal evaluation
;; then tweak the initform to make it fit and emit
;; a warning accordingly.
(push (format "Ambiguous initform needs quoting: %S" init)
warnings)))
(push
(cons init (format "Ambiguous initform needs quoting: %S" init))
warnings)))
;; Anyone can have an accessor function. This creates a function
;; of the specified name, and also performs a `defsetf' if applicable
@ -242,7 +245,8 @@ This method is obsolete."
`(progn
,@(mapcar (lambda (w)
(macroexp-warn-and-return w `(progn ',w) nil 'compile-only))
(macroexp-warn-and-return
(car w) (cdr w) `(progn ',(cdr w)) nil 'compile-only))
warnings)
;; This test must be created right away so we can have self-
;; referencing classes. ei, a class whose slot can contain only
@ -292,6 +296,7 @@ This method is obsolete."
(if (not (stringp (car slots)))
whole
(macroexp-warn-and-return
(car slots)
(format "Obsolete name arg %S to constructor %S"
(car slots) (car whole))
;; Keep the name arg, for backward compatibility,

5
lisp/emacs-lisp/gv.el
View file

@ -581,7 +581,9 @@ This is like the `&' operator of the C language.
Note: this only works reliably with lexical binding mode, except for very
simple PLACEs such as (symbol-function \\='foo) which will also work in dynamic
binding mode."
(let ((code
(let ((org-place place) ; It's too difficult to determine by inspection whether
; the functions modify place.
(code
(gv-letplace (getter setter) place
`(cons (lambda () ,getter)
(lambda (gv--val) ,(funcall setter 'gv--val))))))
@ -593,6 +595,7 @@ binding mode."
(eq (car-safe code) 'cons))
code
(macroexp-warn-and-return
org-place
"Use of gv-ref probably requires lexical-binding"
code))))

330
lisp/emacs-lisp/macroexp.el
View file

@ -28,6 +28,17 @@
;;; Code:
(defvar byte-compile-form-stack nil
"Dynamic list of successive enclosing forms.
This is used by the warning message routines to determine a
source code position. The most accessible element is the current
most deeply nested form.
Normally a form is manually pushed onto the list at the beginning
of `byte-compile-form', etc., and manually popped off at its end.
This is to preserve the data in it in the event of a
condition-case handling a signaled error.")
;; Bound by the top-level `macroexpand-all', and modified to include any
;; macros defined by `defmacro'.
(defvar macroexpand-all-environment nil)
@ -96,10 +107,11 @@ each clause."
(defun macroexp--compiler-macro (handler form)
(condition-case-unless-debug err
(apply handler form (cdr form))
(let ((symbols-with-pos-enabled t))
(apply handler form (cdr form)))
(error
(message "Compiler-macro error for %S: %S" (car form) err)
form)))
(message "Compiler-macro error for %S: Handler: %S\n%S" (car form) handler err)
form)))
(defun macroexp--funcall-if-compiled (_form)
"Pseudo function used internally by macroexp to delay warnings.
@ -135,21 +147,23 @@ Other uses risk returning non-nil value that point to the wrong file."
(defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key))
(defun macroexp--warn-wrap (msg form category)
(defun macroexp--warn-wrap (arg msg form category)
(let ((when-compiled
(lambda ()
(when (if (consp category)
(apply #'byte-compile-warning-enabled-p category)
(byte-compile-warning-enabled-p category))
(byte-compile-warn "%s" msg)))))
(byte-compile-warn-x arg "%s" msg)))))
`(progn
(macroexp--funcall-if-compiled ',when-compiled)
,form)))
(define-obsolete-function-alias 'macroexp--warn-and-return
#'macroexp-warn-and-return "28.1")
(defun macroexp-warn-and-return (msg form &optional category compile-only)
(defun macroexp-warn-and-return (arg msg form &optional category compile-only)
"Return code equivalent to FORM labeled with warning MSG.
ARG is a symbol (or a form) giving the source code position of FORM
for the message. It should normally be a symbol with position.
CATEGORY is the category of the warning, like the categories that
can appear in `byte-compile-warnings'.
COMPILE-ONLY non-nil means no warning should be emitted if the code
@ -163,7 +177,7 @@ is executed without being compiled first."
;; macroexpand-all gets right back to macroexpanding `form'.
form
(puthash form form macroexp--warned)
(macroexp--warn-wrap msg form category)))
(macroexp--warn-wrap arg msg form category)))
(t
(unless compile-only
(message "%sWarning: %s"
@ -219,6 +233,7 @@ is executed without being compiled first."
(let* ((fun (car form))
(obsolete (get fun 'byte-obsolete-info)))
(macroexp-warn-and-return
fun
(macroexp--obsolete-warning
fun obsolete
(if (symbolp (symbol-function fun))
@ -274,6 +289,7 @@ is executed without being compiled first."
(setq arglist (cdr arglist)))
(if values
(macroexp-warn-and-return
arglist
(format (if (eq values 'too-few)
"attempt to open-code `%s' with too few arguments"
"attempt to open-code `%s' with too many arguments")
@ -303,122 +319,124 @@ Only valid during macro-expansion."
"Expand all macros in FORM.
This is an internal version of `macroexpand-all'.
Assumes the caller has bound `macroexpand-all-environment'."
(if (eq (car-safe form) 'backquote-list*)
;; Special-case `backquote-list*', as it is normally a macro that
;; generates exceedingly deep expansions from relatively shallow input
;; forms. We just process it `in reverse' -- first we expand all the
;; arguments, _then_ we expand the top-level definition.
(macroexpand (macroexp--all-forms form 1)
macroexpand-all-environment)
;; Normal form; get its expansion, and then expand arguments.
(setq form (macroexp-macroexpand form macroexpand-all-environment))
;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when
;; I tried it, it broke the bootstrap :-(
(pcase form
(`(cond . ,clauses)
(macroexp--cons 'cond (macroexp--all-clauses clauses) form))
(`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare))
(macroexp--cons
'condition-case
(macroexp--cons err
(macroexp--cons (macroexp--expand-all body)
(macroexp--all-clauses handlers 1)
(cddr form))
(cdr form))
form))
(`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_)
(push name macroexp--dynvars)
(macroexp--all-forms form 2))
(`(function ,(and f `(lambda . ,_)))
(let ((macroexp--dynvars macroexp--dynvars))
(macroexp--cons 'function
(macroexp--cons (macroexp--all-forms f 2)
nil
(cdr form))
form)))
(`(,(or 'function 'quote) . ,_) form)
(`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body)
pcase--dontcare))
(let ((macroexp--dynvars macroexp--dynvars))
(macroexp--cons
fun
(macroexp--cons
(macroexp--all-clauses bindings 1)
(if (null body)
(macroexp-unprogn
(macroexp-warn-and-return
(format "Empty %s body" fun)
nil nil 'compile-only))
(macroexp--all-forms body))
(cdr form))
form)))
(`(,(and fun `(lambda . ,_)) . ,args)
;; Embedded lambda in function position.
;; If the byte-optimizer is loaded, try to unfold this,
;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the optimizer
;; anyway, but doing it here (i.e. earlier) can sometimes avoid the
;; creation of a closure, thus resulting in much better code.
(let ((newform (macroexp--unfold-lambda form)))
(if (eq newform form)
;; Unfolding failed for some reason, avoid infinite recursion.
(macroexp--cons (macroexp--all-forms fun 2)
(macroexp--all-forms args)
form)
(macroexp--expand-all newform))))
(`(funcall ,exp . ,args)
(let ((eexp (macroexp--expand-all exp))
(eargs (macroexp--all-forms args)))
;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
;; has a compiler-macro, or to unfold it.
(pcase eexp
((and `#',f
(guard (not (or (special-form-p f) (macrop f)))));; bug#46636
(macroexp--expand-all `(,f . ,eargs)))
(_ `(funcall ,eexp . ,eargs)))))
(`(funcall . ,_) form) ;bug#53227
(`(,func . ,_)
(let ((handler (function-get func 'compiler-macro))
(funargs (function-get func 'funarg-positions)))
;; Check functions quoted with ' rather than with #'
(dolist (funarg funargs)
(let ((arg (nth funarg form)))
(when (and (eq 'quote (car-safe arg))
(eq 'lambda (car-safe (cadr arg))))
(setcar (nthcdr funarg form)
(macroexp-warn-and-return
(format "%S quoted with ' rather than with #'"
(let ((f (cadr arg)))
(if (symbolp f) f `(lambda ,(nth 1 f) ...))))
arg)))))
;; Macro expand compiler macros. This cannot be delayed to
;; byte-optimize-form because the output of the compiler-macro can
;; use macros.
(if (null handler)
;; No compiler macro. We just expand each argument (for
;; setq/setq-default this works alright because the variable names
;; are symbols).
(macroexp--all-forms form 1)
;; If the handler is not loaded yet, try (auto)loading the
;; function itself, which may in turn load the handler.
(unless (functionp handler)
(with-demoted-errors "macroexp--expand-all: %S"
(autoload-do-load (indirect-function func) func)))
(let ((newform (macroexp--compiler-macro handler form)))
(if (eq form newform)
;; The compiler macro did not find anything to do.
(if (equal form (setq newform (macroexp--all-forms form 1)))
form
;; Maybe after processing the args, some new opportunities
;; appeared, so let's try the compiler macro again.
(setq form (macroexp--compiler-macro handler newform))
(if (eq newform form)
newform
(macroexp--expand-all newform)))
(macroexp--expand-all newform))))))
(_ form))))
(push form byte-compile-form-stack)
(prog1
(if (eq (car-safe form) 'backquote-list*)
;; Special-case `backquote-list*', as it is normally a macro that
;; generates exceedingly deep expansions from relatively shallow input
;; forms. We just process it `in reverse' -- first we expand all the
;; arguments, _then_ we expand the top-level definition.
(macroexpand (macroexp--all-forms form 1)
macroexpand-all-environment)
;; Normal form; get its expansion, and then expand arguments.
(setq form (macroexp-macroexpand form macroexpand-all-environment))
;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when
;; I tried it, it broke the bootstrap :-(
(pcase form
(`(cond . ,clauses)
(macroexp--cons 'cond (macroexp--all-clauses clauses) form))
(`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare))
(macroexp--cons
'condition-case
(macroexp--cons err
(macroexp--cons (macroexp--expand-all body)
(macroexp--all-clauses handlers 1)
(cddr form))
(cdr form))
form))
(`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_)
(push name macroexp--dynvars)
(macroexp--all-forms form 2))
(`(function ,(and f `(lambda . ,_)))
(let ((macroexp--dynvars macroexp--dynvars))
(macroexp--cons 'function
(macroexp--cons (macroexp--all-forms f 2)
nil
(cdr form))
form)))
(`(,(or 'function 'quote) . ,_) form)
(`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body)
pcase--dontcare))
(let ((macroexp--dynvars macroexp--dynvars))
(macroexp--cons
fun
(macroexp--cons
(macroexp--all-clauses bindings 1)
(if (null body)
(macroexp-unprogn
(macroexp-warn-and-return
fun
(format "Empty %s body" fun)
nil nil 'compile-only))
(macroexp--all-forms body))
(cdr form))
form)))
(`(,(and fun `(lambda . ,_)) . ,args)
;; Embedded lambda in function position.
;; If the byte-optimizer is loaded, try to unfold this,
;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the optimizer
;; anyway, but doing it here (i.e. earlier) can sometimes avoid the
;; creation of a closure, thus resulting in much better code.
(let ((newform (macroexp--unfold-lambda form)))
(if (eq newform form)
;; Unfolding failed for some reason, avoid infinite recursion.
(macroexp--cons (macroexp--all-forms fun 2)
(macroexp--all-forms args)
form)
(macroexp--expand-all newform))))
(`(funcall ,exp . ,args)
(let ((eexp (macroexp--expand-all exp))
(eargs (macroexp--all-forms args)))
;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
;; has a compiler-macro, or to unfold it.
(pcase eexp
((and `#',f
(guard (not (or (special-form-p f) (macrop f))))) ;; bug#46636
(macroexp--expand-all `(,f . ,eargs)))
(_ `(funcall ,eexp . ,eargs)))))
(`(funcall . ,_) form) ;bug#53227
(`(,func . ,_)
(let ((handler (function-get func 'compiler-macro))
(funargs (function-get func 'funarg-positions)))
;; Check functions quoted with ' rather than with #'
(dolist (funarg funargs)
(let ((arg (nth funarg form)))
(when (and (eq 'quote (car-safe arg))
(eq 'lambda (car-safe (cadr arg))))
(setcar (nthcdr funarg form)
(macroexp-warn-and-return
(cadr arg)
(format "%S quoted with ' rather than with #'"
(let ((f (cadr arg)))
(if (symbolp f) f `(lambda ,(nth 1 f) ...))))
arg)))))
;; Macro expand compiler macros. This cannot be delayed to
;; byte-optimize-form because the output of the compiler-macro can
;; use macros.
(if (null handler)
;; No compiler macro. We just expand each argument (for
;; setq/setq-default this works alright because the variable names
;; are symbols).
(macroexp--all-forms form 1)
;; If the handler is not loaded yet, try (auto)loading the
;; function itself, which may in turn load the handler.
(unless (functionp handler)
(with-demoted-errors "macroexp--expand-all: %S"
(autoload-do-load (indirect-function func) func)))
(let ((newform (macroexp--compiler-macro handler form)))
(if (eq form newform)
;; The compiler macro did not find anything to do.
(if (equal form (setq newform (macroexp--all-forms form 1)))
form
;; Maybe after processing the args, some new opportunities
;; appeared, so let's try the compiler macro again.
(setq form (macroexp--compiler-macro handler newform))
(if (eq newform form)
newform
(macroexp--expand-all newform)))
(macroexp--expand-all newform))))))
(_ form)))
(pop byte-compile-form-stack)))
;; Record which arguments expect functions, so we can warn when those
;; are accidentally quoted with ' rather than with #'
@ -708,38 +726,40 @@ test of free variables in the following ways:
(defun internal-macroexpand-for-load (form full-p)
;; Called from the eager-macroexpansion in readevalloop.
(cond
;; Don't repeat the same warning for every top-level element.
((eq 'skip (car macroexp--pending-eager-loads)) form)
;; If we detect a cycle, skip macro-expansion for now, and output a warning
;; with a trimmed backtrace.
((and load-file-name (member load-file-name macroexp--pending-eager-loads))
(let* ((bt (delq nil
(mapcar #'macroexp--trim-backtrace-frame
(macroexp--backtrace))))
(elem `(load ,(file-name-nondirectory load-file-name)))
(tail (member elem (cdr (member elem bt)))))
(if tail (setcdr tail (list '…)))
(if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt)))
(if macroexp--debug-eager
(debug 'eager-macroexp-cycle)
(message "Warning: Eager macro-expansion skipped due to cycle:\n %s"
(mapconcat #'prin1-to-string (nreverse bt) " => ")))
(push 'skip macroexp--pending-eager-loads)
form))
(t
(condition-case err
(let ((macroexp--pending-eager-loads
(cons load-file-name macroexp--pending-eager-loads)))
(if full-p
(macroexpand--all-toplevel form)
(macroexpand form)))
(error
;; Hopefully this shouldn't happen thanks to the cycle detection,
;; but in case it does happen, let's catch the error and give the
;; code a chance to macro-expand later.
(message "Eager macro-expansion failure: %S" err)
form)))))
(let ((symbols-with-pos-enabled t)
(print-symbols-bare t))
(cond
;; Don't repeat the same warning for every top-level element.
((eq 'skip (car macroexp--pending-eager-loads)) form)
;; If we detect a cycle, skip macro-expansion for now, and output a warning
;; with a trimmed backtrace.
((and load-file-name (member load-file-name macroexp--pending-eager-loads))
(let* ((bt (delq nil
(mapcar #'macroexp--trim-backtrace-frame
(macroexp--backtrace))))
(elem `(load ,(file-name-nondirectory load-file-name)))
(tail (member elem (cdr (member elem bt)))))
(if tail (setcdr tail (list '…)))
(if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt)))
(if macroexp--debug-eager
(debug 'eager-macroexp-cycle)
(message "Warning: Eager macro-expansion skipped due to cycle:\n %s"
(mapconcat #'prin1-to-string (nreverse bt) " => ")))
(push 'skip macroexp--pending-eager-loads)
form))
(t
(condition-case err
(let ((macroexp--pending-eager-loads
(cons load-file-name macroexp--pending-eager-loads)))
(if full-p
(macroexpand--all-toplevel form)
(macroexpand form)))
(error
;; Hopefully this shouldn't happen thanks to the cycle detection,
;; but in case it does happen, let's catch the error and give the
;; code a chance to macro-expand later.
(message "Eager macro-expansion failure: %S" err)
form))))))
;; ¡¡¡ Big Ugly Hack !!!
;; src/bootstrap-emacs is mostly used to compile .el files, so it needs

2
lisp/emacs-lisp/pcase.el
View file

@ -433,6 +433,7 @@ how many time this CODEGEN is called."
(memq (car case) pcase--dontwarn-upats))
(setq main
(macroexp-warn-and-return
(car case)
(format "pcase pattern %S shadowed by previous pcase pattern"
(car case))
main))))
@ -940,6 +941,7 @@ Otherwise, it defers to REST which is a list of branches of the form
(let ((code (pcase--u1 matches code vars rest)))
(if (eq upat '_) code
(macroexp-warn-and-return
upat
"Pattern t is deprecated. Use `_' instead"
code))))
((eq upat 'pcase--dontcare) :pcase--dontcare)

2
lisp/help.el
View file

@ -2069,7 +2069,7 @@ the same names as used in the original source code, when possible."
((symbolp arg)
(let ((name (symbol-name arg)))
(cond
((string-match "\\`&" name) arg)
((string-match "\\`&" name) (bare-symbol arg))
((string-match "\\`_." name)
(intern (upcase (substring name 1))))
(t (intern (upcase name))))))

11
lisp/keymap.el
View file

@ -462,18 +462,19 @@ If MESSAGE (and interactively), message the result."
(keywordp (car args))
(not (eq (car args) :menu)))
(unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix))
(byte-compile-warn "Invalid keyword: %s" (car args)))
(byte-compile-warn-x (car args) "Invalid keyword: %s" (car args)))
(setq args (cdr args))
(when (null args)
(byte-compile-warn "Uneven number of keywords in %S" form))
(byte-compile-warn-x form "Uneven number of keywords in %S" form))
(setq args (cdr args)))
;; Bindings.
(while args
(let ((key (pop args)))
(let* ((wargs args)
(key (pop args)))
(when (and (stringp key) (not (key-valid-p key)))
(byte-compile-warn "Invalid `kbd' syntax: %S" key)))
(byte-compile-warn-x wargs "Invalid `kbd' syntax: %S" key)))
(when (null args)
(byte-compile-warn "Uneven number of key bindings in %S" form))
(byte-compile-warn-x form "Uneven number of key bindings in %S" form))
(setq args (cdr args)))
form)

12
src/.gdbinit
View file

@ -751,6 +751,15 @@ Print $ as a overlay pointer.
This command assumes that $ is an Emacs Lisp overlay value.
end
define xsymwithpos
xgetptr $
print (struct Lisp_Symbol_With_Pos *) $ptr
end
document xsymwithpos
Print $ as a symbol with position.
This command assumes that $ is an Emacs Lisp symbol with position value.
end
define xsymbol
set $sym = $
xgetsym $sym
@ -1016,6 +1025,9 @@ define xpr
if $vec == PVEC_OVERLAY
xoverlay
end
if $vec == PVEC_SYMBOL_WITH_POS
xsymwithpos
end
if $vec == PVEC_PROCESS
xprocess
end

40
src/alloc.c
View file

@ -592,7 +592,7 @@ pointer_align (void *ptr, int alignment)
static ATTRIBUTE_NO_SANITIZE_UNDEFINED void *
XPNTR (Lisp_Object a)
{
return (SYMBOLP (a)
return (BARE_SYMBOL_P (a)
? (char *) lispsym + (XLI (a) - LISP_WORD_TAG (Lisp_Symbol))
: (char *) XLP (a) - (XLI (a) & ~VALMASK));
}
@ -3599,13 +3599,13 @@ static struct Lisp_Symbol *symbol_free_list;
static void
set_symbol_name (Lisp_Object sym, Lisp_Object name)
{
XSYMBOL (sym)->u.s.name = name;
XBARE_SYMBOL (sym)->u.s.name = name;
}
void
init_symbol (Lisp_Object val, Lisp_Object name)
{
struct Lisp_Symbol *p = XSYMBOL (val);
struct Lisp_Symbol *p = XBARE_SYMBOL (val);
set_symbol_name (val, name);
set_symbol_plist (val, Qnil);
p->u.s.redirect = SYMBOL_PLAINVAL;
@ -3668,6 +3668,21 @@ make_misc_ptr (void *a)
return make_lisp_ptr (p, Lisp_Vectorlike);
}
/* Return a new symbol with position with the specified SYMBOL and POSITION. */
Lisp_Object
build_symbol_with_pos (Lisp_Object symbol, Lisp_Object position)
{
Lisp_Object val;
struct Lisp_Symbol_With_Pos *p
= (struct Lisp_Symbol_With_Pos *) allocate_vector (2);
XSETVECTOR (val, p);
XSETPVECTYPESIZE (XVECTOR (val), PVEC_SYMBOL_WITH_POS, 2, 0);
p->sym = symbol;
p->pos = position;
return val;
}
/* Return a new overlay with specified START, END and PLIST. */
Lisp_Object
@ -5212,7 +5227,7 @@ valid_lisp_object_p (Lisp_Object obj)
if (PURE_P (p))
return 1;
if (SYMBOLP (obj) && c_symbol_p (p))
if (BARE_SYMBOL_P (obj) && c_symbol_p (p))
return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0;
if (p == &buffer_defaults || p == &buffer_local_symbols)
@ -5640,12 +5655,12 @@ purecopy (Lisp_Object obj)
vec->contents[i] = purecopy (vec->contents[i]);
XSETVECTOR (obj, vec);
}
else if (SYMBOLP (obj))
else if (BARE_SYMBOL_P (obj))
{
if (!XSYMBOL (obj)->u.s.pinned && !c_symbol_p (XSYMBOL (obj)))
if (!XBARE_SYMBOL (obj)->u.s.pinned && !c_symbol_p (XBARE_SYMBOL (obj)))
{ /* We can't purify them, but they appear in many pure objects.
Mark them as `pinned' so we know to mark them at every GC cycle. */
XSYMBOL (obj)->u.s.pinned = true;
XBARE_SYMBOL (obj)->u.s.pinned = true;
symbol_block_pinned = symbol_block;
}
/* Don't hash-cons it. */
@ -6273,7 +6288,10 @@ For further details, see Info node `(elisp)Garbage Collection'. */)
if (garbage_collection_inhibited)
return Qnil;
ptrdiff_t count = SPECPDL_INDEX ();
specbind (Qsymbols_with_pos_enabled, Qnil);
garbage_collect ();
unbind_to (count, Qnil);
struct gcstat gcst = gcstat;
Lisp_Object total[] = {
@ -6412,7 +6430,7 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype)
Lisp_Object val = ptr->contents[i];
if (FIXNUMP (val) ||
(SYMBOLP (val) && symbol_marked_p (XSYMBOL (val))))
(BARE_SYMBOL_P (val) && symbol_marked_p (XBARE_SYMBOL (val))))
continue;
if (SUB_CHAR_TABLE_P (val))
{
@ -6816,7 +6834,7 @@ mark_object (Lisp_Object arg)
case Lisp_Symbol:
{
struct Lisp_Symbol *ptr = XSYMBOL (obj);
struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj);
nextsym:
if (symbol_marked_p (ptr))
break;
@ -6937,7 +6955,7 @@ survives_gc_p (Lisp_Object obj)
break;
case Lisp_Symbol:
survives_p = symbol_marked_p (XSYMBOL (obj));
survives_p = symbol_marked_p (XBARE_SYMBOL (obj));
break;
case Lisp_String:
@ -7354,7 +7372,7 @@ arenas. */)
static bool
symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj)
{
struct Lisp_Symbol *sym = XSYMBOL (symbol);
struct Lisp_Symbol *sym = XBARE_SYMBOL (symbol);
Lisp_Object val = find_symbol_value (symbol);
return (EQ (val, obj)
|| EQ (sym->u.s.function, obj)

301
src/comp.c
View file

@ -454,6 +454,7 @@ load_gccjit_if_necessary (bool mandatory)
/* C symbols emitted for the load relocation mechanism. */
#define CURRENT_THREAD_RELOC_SYM "current_thread_reloc"
#define F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM "f_symbols_with_pos_enabled_reloc"
#define PURE_RELOC_SYM "pure_reloc"
#define DATA_RELOC_SYM "d_reloc"
#define DATA_RELOC_IMPURE_SYM "d_reloc_imp"
@ -542,6 +543,7 @@ typedef struct {
gcc_jit_type *emacs_int_type;
gcc_jit_type *emacs_uint_type;
gcc_jit_type *void_ptr_type;
gcc_jit_type *bool_ptr_type;
gcc_jit_type *char_ptr_type;
gcc_jit_type *ptrdiff_type;
gcc_jit_type *uintptr_type;
@ -563,6 +565,16 @@ typedef struct {
gcc_jit_field *lisp_cons_u_s_u_cdr;
gcc_jit_type *lisp_cons_type;
gcc_jit_type *lisp_cons_ptr_type;
/* struct Lisp_Symbol_With_Position */
gcc_jit_rvalue *f_symbols_with_pos_enabled_ref;
gcc_jit_struct *lisp_symbol_with_position;
gcc_jit_field *lisp_symbol_with_position_header;
gcc_jit_field *lisp_symbol_with_position_sym;
gcc_jit_field *lisp_symbol_with_position_pos;
gcc_jit_type *lisp_symbol_with_position_type;
gcc_jit_type *lisp_symbol_with_position_ptr_type;
gcc_jit_function *get_symbol_with_position;
gcc_jit_function *symbol_with_pos_sym;
/* struct jmp_buf. */
gcc_jit_struct *jmp_buf_s;
/* struct handler. */
@ -655,7 +667,10 @@ Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x);
Lisp_Object helper_unbind_n (Lisp_Object n);
void helper_save_restriction (void);
bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code);
struct Lisp_Symbol_With_Pos *helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a);
/* Note: helper_link_table must match the list created by
`declare_runtime_imported_funcs'. */
void *helper_link_table[] =
{ wrong_type_argument,
helper_PSEUDOVECTOR_TYPEP_XUNTAG,
@ -664,6 +679,7 @@ void *helper_link_table[] =
record_unwind_protect_excursion,
helper_unbind_n,
helper_save_restriction,
helper_GET_SYMBOL_WITH_POSITION,
record_unwind_current_buffer,
set_internal,
helper_unwind_protect,
@ -1328,9 +1344,9 @@ emit_XCONS (gcc_jit_rvalue *a)
}
static gcc_jit_rvalue *
emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
emit_BASE_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
{
emit_comment ("EQ");
emit_comment ("BASE_EQ");
return gcc_jit_context_new_comparison (
comp.ctxt,
@ -1340,6 +1356,30 @@ emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
emit_XLI (y));
}
static gcc_jit_rvalue *
emit_AND (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
{
return gcc_jit_context_new_binary_op (
comp.ctxt,
NULL,
GCC_JIT_BINARY_OP_LOGICAL_AND,
comp.bool_type,
x,
y);
}
static gcc_jit_rvalue *
emit_OR (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
{
return gcc_jit_context_new_binary_op (
comp.ctxt,
NULL,
GCC_JIT_BINARY_OP_LOGICAL_OR,
comp.bool_type,
x,
y);
}
static gcc_jit_rvalue *
emit_TAGGEDP (gcc_jit_rvalue *obj, Lisp_Word_tag tag)
{
@ -1401,6 +1441,85 @@ emit_CONSP (gcc_jit_rvalue *obj)
return emit_TAGGEDP (obj, Lisp_Cons);
}
static gcc_jit_rvalue *
emit_BARE_SYMBOL_P (gcc_jit_rvalue *obj)
{
emit_comment ("BARE_SYMBOL_P");
return gcc_jit_context_new_cast (comp.ctxt,
NULL,
emit_TAGGEDP (obj, Lisp_Symbol),
comp.bool_type);
}
static gcc_jit_rvalue *
emit_SYMBOL_WITH_POS_P (gcc_jit_rvalue *obj)
{
emit_comment ("SYMBOL_WITH_POS_P");
gcc_jit_rvalue *args[] =
{ obj,
gcc_jit_context_new_rvalue_from_int (comp.ctxt,
comp.int_type,
PVEC_SYMBOL_WITH_POS)
};
return gcc_jit_context_new_call (comp.ctxt,
NULL,
comp.pseudovectorp,
2,
args);
}
static gcc_jit_rvalue *
emit_SYMBOL_WITH_POS_SYM (gcc_jit_rvalue *obj)
{
emit_comment ("SYMBOL_WITH_POS_SYM");
gcc_jit_rvalue *arg [] = { obj };
return gcc_jit_context_new_call (comp.ctxt,
NULL,
comp.symbol_with_pos_sym,
1,
arg);
}
static gcc_jit_rvalue *
emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
{
return
emit_OR (
gcc_jit_context_new_comparison (
comp.ctxt, NULL,
GCC_JIT_COMPARISON_EQ,
emit_XLI (x), emit_XLI (y)),
emit_AND (
gcc_jit_lvalue_as_rvalue (
gcc_jit_rvalue_dereference (comp.f_symbols_with_pos_enabled_ref,
NULL)),
emit_OR (
emit_AND (
emit_SYMBOL_WITH_POS_P (x),
emit_OR (
emit_AND (
emit_SYMBOL_WITH_POS_P (y),
emit_BASE_EQ (
emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)),
emit_XLI (emit_SYMBOL_WITH_POS_SYM (y)))),
emit_AND (
emit_BARE_SYMBOL_P (y),
emit_BASE_EQ (
emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)),
emit_XLI (y))))),
emit_AND (
emit_BARE_SYMBOL_P (x),
emit_AND (
emit_SYMBOL_WITH_POS_P (y),
emit_BASE_EQ (
emit_XLI (x),
emit_XLI (emit_SYMBOL_WITH_POS_SYM (y))))))));
}
static gcc_jit_rvalue *
emit_FLOATP (gcc_jit_rvalue *obj)
{
@ -1615,7 +1734,7 @@ static gcc_jit_rvalue *
emit_NILP (gcc_jit_rvalue *x)
{
emit_comment ("NILP");
return emit_EQ (x, emit_lisp_obj_rval (Qnil));
return emit_BASE_EQ (x, emit_lisp_obj_rval (Qnil));
}
static gcc_jit_rvalue *
@ -1731,6 +1850,29 @@ emit_CHECK_CONS (gcc_jit_rvalue *x)
args));
}
static void
emit_CHECK_SYMBOL_WITH_POS (gcc_jit_rvalue *x)
{
emit_comment ("CHECK_SYMBOL_WITH_POS");
gcc_jit_rvalue *args[] =
{ gcc_jit_context_new_cast (comp.ctxt,
NULL,
emit_SYMBOL_WITH_POS_P (x),
comp.int_type),
emit_lisp_obj_rval (Qsymbol_with_pos_p),
x };
gcc_jit_block_add_eval (
comp.block,
NULL,
gcc_jit_context_new_call (comp.ctxt,
NULL,
comp.check_type,
3,
args));
}
static gcc_jit_rvalue *
emit_car_addr (gcc_jit_rvalue *c)
{
@ -2095,7 +2237,13 @@ emit_limple_insn (Lisp_Object insn)
gcc_jit_block *target1 = retrive_block (arg[2]);
gcc_jit_block *target2 = retrive_block (arg[3]);
emit_cond_jump (emit_EQ (a, b), target1, target2);
if ((CALL1I (comp-cstr-imm-vld-p, arg[0])
&& NILP (CALL1I (comp-cstr-imm, arg[0])))
|| (CALL1I (comp-cstr-imm-vld-p, arg[1])
&& NILP (CALL1I (comp-cstr-imm, arg[1]))))
emit_cond_jump (emit_BASE_EQ (a, b), target1, target2);
else
emit_cond_jump (emit_EQ (a, b), target1, target2);
}
else if (EQ (op, Qcond_jump_narg_leq))
{
@ -2714,7 +2862,8 @@ declare_imported_data (void)
/*
Declare as imported all the functions that are requested from the runtime.
These are either subrs or not.
These are either subrs or not. Note that the list created here must match
the array `helper_link_table'.
*/
static Lisp_Object
declare_runtime_imported_funcs (void)
@ -2751,6 +2900,10 @@ declare_runtime_imported_funcs (void)
ADD_IMPORTED (helper_save_restriction, comp.void_type, 0, NULL);
args[0] = comp.lisp_obj_type;
ADD_IMPORTED (helper_GET_SYMBOL_WITH_POSITION, comp.lisp_symbol_with_position_ptr_type,
1, args);
ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL);
args[0] = args[1] = args[2] = comp.lisp_obj_type;
@ -2798,6 +2951,15 @@ emit_ctxt_code (void)
gcc_jit_type_get_pointer (comp.thread_state_ptr_type),
CURRENT_THREAD_RELOC_SYM));
comp.f_symbols_with_pos_enabled_ref =
gcc_jit_lvalue_as_rvalue (
gcc_jit_context_new_global (
comp.ctxt,
NULL,
GCC_JIT_GLOBAL_EXPORTED,
comp.bool_ptr_type,
F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM));
comp.pure_ptr =
gcc_jit_lvalue_as_rvalue (
gcc_jit_context_new_global (
@ -2977,6 +3139,39 @@ define_lisp_cons (void)
}
static void
define_lisp_symbol_with_position (void)
{
comp.lisp_symbol_with_position_header =
gcc_jit_context_new_field (comp.ctxt,
NULL,
comp.ptrdiff_type,
"header");
comp.lisp_symbol_with_position_sym =
gcc_jit_context_new_field (comp.ctxt,
NULL,
comp.lisp_obj_type,
"sym");
comp.lisp_symbol_with_position_pos =
gcc_jit_context_new_field (comp.ctxt,
NULL,
comp.lisp_obj_type,
"pos");
gcc_jit_field *fields [3] = {comp.lisp_symbol_with_position_header,
comp.lisp_symbol_with_position_sym,
comp.lisp_symbol_with_position_pos};
comp.lisp_symbol_with_position =
gcc_jit_context_new_struct_type (comp.ctxt,
NULL,
"comp_lisp_symbol_with_position",
3,
fields);
comp.lisp_symbol_with_position_type =
gcc_jit_struct_as_type (comp.lisp_symbol_with_position);
comp.lisp_symbol_with_position_ptr_type =
gcc_jit_type_get_pointer (comp.lisp_symbol_with_position_type);
}
/* Opaque jmp_buf definition. */
static void
@ -3672,6 +3867,82 @@ define_PSEUDOVECTORP (void)
comp.bool_type, 2, args, false));
}
static void
define_GET_SYMBOL_WITH_POSITION (void)
{
gcc_jit_param *param[] =
{ gcc_jit_context_new_param (comp.ctxt,
NULL,
comp.lisp_obj_type,
"a") };
comp.get_symbol_with_position =
gcc_jit_context_new_function (comp.ctxt, NULL,
GCC_JIT_FUNCTION_INTERNAL,
comp.lisp_symbol_with_position_ptr_type,
"GET_SYMBOL_WITH_POSITION",
1,
param,
0);
DECL_BLOCK (entry_block, comp.get_symbol_with_position);
comp.block = entry_block;
comp.func = comp.get_symbol_with_position;
gcc_jit_rvalue *args[] =
{ gcc_jit_param_as_rvalue (param[0]) };
/* FIXME use XUNTAG now that's available. */
gcc_jit_block_end_with_return (
entry_block,
NULL,
emit_call (intern_c_string ("helper_GET_SYMBOL_WITH_POSITION"),
comp.lisp_symbol_with_position_ptr_type,
1, args, false));
}
static void define_SYMBOL_WITH_POS_SYM (void)
{
gcc_jit_rvalue *tmpr, *swp;
gcc_jit_lvalue *tmpl;
gcc_jit_param *param [] =
{ gcc_jit_context_new_param (comp.ctxt,
NULL,
comp.lisp_obj_type,
"a") };
comp.symbol_with_pos_sym =
gcc_jit_context_new_function (comp.ctxt, NULL,
GCC_JIT_FUNCTION_INTERNAL,
comp.lisp_obj_type,
"SYMBOL_WITH_POS_SYM",
1,
param,
0);
DECL_BLOCK (entry_block, comp.symbol_with_pos_sym);
comp.func = comp.symbol_with_pos_sym;
comp.block = entry_block;
emit_CHECK_SYMBOL_WITH_POS (gcc_jit_param_as_rvalue (param [0]));
gcc_jit_rvalue *args[] = { gcc_jit_param_as_rvalue (param [0]) };
swp = gcc_jit_context_new_call (comp.ctxt,
NULL,
comp.get_symbol_with_position,
1,
args);
tmpl = gcc_jit_rvalue_dereference (swp, NULL);
tmpr = gcc_jit_lvalue_as_rvalue (tmpl);
gcc_jit_block_end_with_return (entry_block,
NULL,
gcc_jit_rvalue_access_field (
tmpr,
NULL,
comp.lisp_symbol_with_position_sym));
}
static void
define_CHECK_IMPURE (void)
{
@ -4309,6 +4580,7 @@ Return t on success. */)
gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG);
comp.unsigned_long_long_type =
gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG);
comp.bool_ptr_type = gcc_jit_type_get_pointer (comp.bool_type);
comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type);
comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt,
sizeof (EMACS_INT),
@ -4381,6 +4653,7 @@ Return t on success. */)
/* Define data structures. */
define_lisp_cons ();
define_lisp_symbol_with_position ();
define_jmp_buf ();
define_handler_struct ();
define_thread_state_struct ();
@ -4602,7 +4875,9 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file,
/* Define inline functions. */
define_CAR_CDR ();
define_PSEUDOVECTORP ();
define_GET_SYMBOL_WITH_POSITION ();
define_CHECK_TYPE ();
define_SYMBOL_WITH_POS_SYM ();
define_CHECK_IMPURE ();
define_bool_to_lisp_obj ();
define_setcar_setcdr ();
@ -4734,6 +5009,14 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code)
code);
}
struct Lisp_Symbol_With_Pos *
helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a)
{
if (!SYMBOL_WITH_POS_P (a))
wrong_type_argument (Qwrong_type_argument, a);
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos);
}
/* `native-comp-eln-load-path' clean-up support code. */
@ -5000,12 +5283,15 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump,
{
struct thread_state ***current_thread_reloc =
dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM);
bool **f_symbols_with_pos_enabled_reloc =
dynlib_sym (handle, F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM);
void **pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM);
Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM);
Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs;
void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM);
if (!(current_thread_reloc
&& f_symbols_with_pos_enabled_reloc
&& pure_reloc
&& data_relocs
&& data_imp_relocs
@ -5017,6 +5303,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump,
xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
*current_thread_reloc = &current_thread;
*f_symbols_with_pos_enabled_reloc = &symbols_with_pos_enabled;
*pure_reloc = pure;
/* Imported functions. */
@ -5386,6 +5673,7 @@ compiled one. */);
DEFSYM (Qnumberp, "numberp");
DEFSYM (Qintegerp, "integerp");
DEFSYM (Qcomp_maybe_gc_or_quit, "comp-maybe-gc-or-quit");
DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p");
/* Allocation classes. */
DEFSYM (Qd_default, "d-default");
@ -5536,3 +5824,6 @@ be preloaded. */);
defsubr (&Snative_comp_available_p);
}
/* Local Variables: */
/* c-file-offsets: ((arglist-intro . +)) */
/* End: */

109
src/data.c
View file

@ -216,6 +216,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_SYMBOL_WITH_POS: return Qsymbol_with_pos;
case PVEC_OVERLAY: return Qoverlay;
case PVEC_FINALIZER: return Qfinalizer;
case PVEC_USER_PTR: return Quser_ptr;
@ -318,6 +319,26 @@ DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
return Qt;
}
DEFUN ("bare-symbol-p", Fbare_symbol_p, Sbare_symbol_p, 1, 1, 0,
doc: /* Return t if OBJECT is a symbol, but not a symbol together with position. */
attributes: const)
(Lisp_Object object)
{
if (BARE_SYMBOL_P (object))
return Qt;
return Qnil;
}
DEFUN ("symbol-with-pos-p", Fsymbol_with_pos_p, Ssymbol_with_pos_p, 1, 1, 0,
doc: /* Return t if OBJECT is a symbol together with position. */
attributes: const)
(Lisp_Object object)
{
if (SYMBOL_WITH_POS_P (object))
return Qt;
return Qnil;
}
DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
doc: /* Return t if OBJECT is a symbol. */
attributes: const)
@ -755,6 +776,62 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
return name;
}
DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0,
doc: /* Extract, if need be, the bare symbol from SYM, a symbol. */)
(register Lisp_Object sym)
{
if (BARE_SYMBOL_P (sym))
return sym;
/* Type checking is done in the following macro. */
return SYMBOL_WITH_POS_SYM (sym);
}
DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, 1, 1, 0,
doc: /* Extract the position from a symbol with position. */)
(register Lisp_Object ls)
{
/* Type checking is done in the following macro. */
return SYMBOL_WITH_POS_POS (ls);
}
DEFUN ("remove-pos-from-symbol", Fremove_pos_from_symbol,
Sremove_pos_from_symbol, 1, 1, 0,
doc: /* If ARG is a symbol with position, return it without the position.
Otherwise, return ARG unchanged. Compare with `bare-symbol'. */)
(register Lisp_Object arg)
{
if (SYMBOL_WITH_POS_P (arg))
return (SYMBOL_WITH_POS_SYM (arg));
return arg;
}
DEFUN ("position-symbol", Fposition_symbol, Sposition_symbol, 2, 2, 0,
doc: /* Create a new symbol with position.
SYM is a symbol, with or without position, the symbol to position.
POS, the position, is either a fixnum or a symbol with position from which
the position will be taken. */)
(register Lisp_Object sym, register Lisp_Object pos)
{
Lisp_Object bare;
Lisp_Object position;
if (BARE_SYMBOL_P (sym))
bare = sym;
else if (SYMBOL_WITH_POS_P (sym))
bare = XSYMBOL_WITH_POS (sym)->sym;
else
wrong_type_argument (Qsymbolp, sym);
if (FIXNUMP (pos))
position = pos;
else if (SYMBOL_WITH_POS_P (pos))
position = XSYMBOL_WITH_POS (pos)->pos;
else
wrong_type_argument (Qfixnum_or_symbol_with_pos_p, pos);
return build_symbol_with_pos (bare, position);
}
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)
@ -3892,7 +3969,7 @@ A is a bool vector, B is t or nil, and I is an index into A. */)
void
syms_of_data (void)
{
Lisp_Object error_tail, arith_tail;
Lisp_Object error_tail, arith_tail, recursion_tail;
DEFSYM (Qquote, "quote");
DEFSYM (Qlambda, "lambda");
@ -3927,8 +4004,14 @@ syms_of_data (void)
DEFSYM (Qmark_inactive, "mark-inactive");
DEFSYM (Qinhibited_interaction, "inhibited-interaction");
DEFSYM (Qrecursion_error, "recursion-error");
DEFSYM (Qexcessive_variable_binding, "excessive-variable-binding");
DEFSYM (Qexcessive_lisp_nesting, "excessive-lisp-nesting");
DEFSYM (Qlistp, "listp");
DEFSYM (Qconsp, "consp");
DEFSYM (Qbare_symbol_p, "bare-symbol-p");
DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p");
DEFSYM (Qsymbolp, "symbolp");
DEFSYM (Qfixnump, "fixnump");
DEFSYM (Qintegerp, "integerp");
@ -3954,6 +4037,7 @@ syms_of_data (void)
DEFSYM (Qchar_table_p, "char-table-p");
DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p");
DEFSYM (Qfixnum_or_symbol_with_pos_p, "fixnum-or-symbol-with-pos-p");
DEFSYM (Qsubrp, "subrp");
DEFSYM (Qunevalled, "unevalled");
@ -4032,12 +4116,23 @@ syms_of_data (void)
PUT_ERROR (Qunderflow_error, Fcons (Qrange_error, arith_tail),
"Arithmetic underflow error");
recursion_tail = pure_cons (Qrecursion_error, error_tail);
Fput (Qrecursion_error, Qerror_conditions, recursion_tail);
Fput (Qrecursion_error, Qerror_message, build_pure_c_string
("Excessive recursive calling error"));
PUT_ERROR (Qexcessive_variable_binding, recursion_tail,
"Variable binding depth exceeds max-specpdl-size");
PUT_ERROR (Qexcessive_lisp_nesting, recursion_tail,
"Lisp nesting exceeds `max-lisp-eval-depth'");
/* Types that type-of returns. */
DEFSYM (Qinteger, "integer");
DEFSYM (Qsymbol, "symbol");
DEFSYM (Qstring, "string");
DEFSYM (Qcons, "cons");
DEFSYM (Qmarker, "marker");
DEFSYM (Qsymbol_with_pos, "symbol-with-pos");
DEFSYM (Qoverlay, "overlay");
DEFSYM (Qfinalizer, "finalizer");
DEFSYM (Qmodule_function, "module-function");
@ -4089,6 +4184,8 @@ syms_of_data (void)
defsubr (&Snumber_or_marker_p);
defsubr (&Sfloatp);
defsubr (&Snatnump);
defsubr (&Sbare_symbol_p);
defsubr (&Ssymbol_with_pos_p);
defsubr (&Ssymbolp);
defsubr (&Skeywordp);
defsubr (&Sstringp);
@ -4119,6 +4216,10 @@ syms_of_data (void)
defsubr (&Sindirect_function);
defsubr (&Ssymbol_plist);
defsubr (&Ssymbol_name);
defsubr (&Sbare_symbol);
defsubr (&Ssymbol_with_pos_pos);
defsubr (&Sremove_pos_from_symbol);
defsubr (&Sposition_symbol);
defsubr (&Smakunbound);
defsubr (&Sfmakunbound);
defsubr (&Sboundp);
@ -4201,6 +4302,12 @@ 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"));
DEFSYM (Qsymbols_with_pos_enabled, "symbols-with-pos-enabled");
DEFVAR_BOOL ("symbols-with-pos-enabled", symbols_with_pos_enabled,
doc: /* Non-nil when "symbols with position" can be used as symbols.
Bind this to non-nil in applications such as the byte compiler. */);
symbols_with_pos_enabled = false;
DEFSYM (Qwatchers, "watchers");
DEFSYM (Qmakunbound, "makunbound");
DEFSYM (Qunlet, "unlet");

7
src/eval.c
View file

@ -2395,8 +2395,7 @@ grow_specpdl (void)
if (max_specpdl_size < 400)
max_size = max_specpdl_size = 400;
if (max_size <= specpdl_size)
signal_error ("Variable binding depth exceeds max-specpdl-size",
Qnil);
xsignal0 (Qexcessive_variable_binding);
}
pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl);
specpdl = pdlvec + 1;
@ -2450,7 +2449,7 @@ eval_sub (Lisp_Object form)
if (max_lisp_eval_depth < 100)
max_lisp_eval_depth = 100;
if (lisp_eval_depth > max_lisp_eval_depth)
error ("Lisp nesting exceeds `max-lisp-eval-depth'");
xsignal0 (Qexcessive_lisp_nesting);
}
Lisp_Object original_fun = XCAR (form);
@ -3054,7 +3053,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
if (max_lisp_eval_depth < 100)
max_lisp_eval_depth = 100;
if (lisp_eval_depth > max_lisp_eval_depth)
error ("Lisp nesting exceeds `max-lisp-eval-depth'");
xsignal0 (Qexcessive_lisp_nesting);
}
count = record_in_backtrace (args[0], &args[1], nargs - 1);

12
src/fns.c
View file

@ -2569,6 +2569,13 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
}
}
/* A symbol with position compares the contained symbol, and is
`equal' to the corresponding ordinary symbol. */
if (SYMBOL_WITH_POS_P (o1))
o1 = SYMBOL_WITH_POS_SYM (o1);
if (SYMBOL_WITH_POS_P (o2))
o2 = SYMBOL_WITH_POS_SYM (o2);
if (EQ (o1, o2))
return true;
if (XTYPE (o1) != XTYPE (o2))
@ -4479,7 +4486,10 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object *hash)
{
ptrdiff_t start_of_bucket, i;
Lisp_Object hash_code = h->test.hashfn (key, h);
Lisp_Object hash_code;
if (SYMBOL_WITH_POS_P (key))
key = SYMBOL_WITH_POS_SYM (key);
hash_code = h->test.hashfn (key, h);
if (hash)
*hash = hash_code;

2
src/keyboard.c
View file

@ -689,6 +689,8 @@ recursive_edit_1 (void)
{
specbind (Qstandard_output, Qt);
specbind (Qstandard_input, Qt);
specbind (Qsymbols_with_pos_enabled, Qnil);
specbind (Qprint_symbols_bare, Qnil);
}
#ifdef HAVE_WINDOW_SYSTEM

216
src/lisp.h
View file

@ -353,18 +353,38 @@ typedef EMACS_INT Lisp_Word;
# endif
#endif
#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))))
#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) \
((ok) ? (void) 0 : wrong_type_argument (predicate, x))
#define lisp_h_CONSP(x) TAGGEDP (x, Lisp_Cons)
#define lisp_h_EQ(x, y) (XLI (x) == XLI (y))
#define lisp_h_BASE_EQ(x, y) (XLI (x) == XLI (y))
/* #define lisp_h_EQ(x, y) (XLI (x) == XLI (y)) */
#define lisp_h_EQ(x, y) ((XLI ((x)) == XLI ((y))) \
|| (symbols_with_pos_enabled \
&& (SYMBOL_WITH_POS_P ((x)) \
? BARE_SYMBOL_P ((y)) \
? XLI (XSYMBOL_WITH_POS((x))->sym) == XLI (y) \
: SYMBOL_WITH_POS_P((y)) \
&& (XLI (XSYMBOL_WITH_POS((x))->sym) \
== XLI (XSYMBOL_WITH_POS((y))->sym)) \
: (SYMBOL_WITH_POS_P ((y)) \
&& BARE_SYMBOL_P ((x)) \
&& (XLI (x) == XLI ((XSYMBOL_WITH_POS ((y)))->sym))))))
#define lisp_h_FIXNUMP(x) \
(! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \
- (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) \
& ((1 << INTTYPEBITS) - 1)))
#define lisp_h_FLOATP(x) TAGGEDP (x, Lisp_Float)
#define lisp_h_NILP(x) EQ (x, Qnil)
#define lisp_h_NILP(x) /* x == Qnil */ /* ((XLI (x) == XLI (Qnil))) */ /* EQ (x, Qnil) */ BASE_EQ (x, Qnil)
#define lisp_h_SET_SYMBOL_VAL(sym, v) \
(eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), \
(sym)->u.s.val.value = (v))
@ -373,7 +393,10 @@ 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_SYMBOL_WITH_POS_P(x) PSEUDOVECTORP ((x), PVEC_SYMBOL_WITH_POS)
#define lisp_h_BARE_SYMBOL_P(x) TAGGEDP ((x), Lisp_Symbol)
#define lisp_h_SYMBOLP(x) ((BARE_SYMBOL_P ((x)) || \
(symbols_with_pos_enabled && (SYMBOL_WITH_POS_P ((x))))))
#define lisp_h_TAGGEDP(a, tag) \
(! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \
- (unsigned) (tag)) \
@ -418,11 +441,12 @@ typedef EMACS_INT Lisp_Word;
# define XLI(o) lisp_h_XLI (o)
# define XIL(i) lisp_h_XIL (i)
# define XLP(o) lisp_h_XLP (o)
# define BARE_SYMBOL_P(x) lisp_h_BARE_SYMBOL_P (x)
# define CHECK_FIXNUM(x) lisp_h_CHECK_FIXNUM (x)
# define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x)
# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x)
# define CONSP(x) lisp_h_CONSP (x)
# define EQ(x, y) lisp_h_EQ (x, y)
# define BASE_EQ(x, y) lisp_h_BASE_EQ (x, y)
# define FLOATP(x) lisp_h_FLOATP (x)
# define FIXNUMP(x) lisp_h_FIXNUMP (x)
# define NILP(x) lisp_h_NILP (x)
@ -430,7 +454,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 SYMBOLP(x) lisp_h_SYMBOLP (x)
/* # define SYMBOLP(x) lisp_h_SYMBOLP (x) */ /* X is accessed more than once. */
# define TAGGEDP(a, tag) lisp_h_TAGGEDP (a, tag)
# define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x)
# define XCAR(c) lisp_h_XCAR (c)
@ -589,6 +613,7 @@ extern Lisp_Object char_table_ref (Lisp_Object, int) ATTRIBUTE_PURE;
extern void char_table_set (Lisp_Object, int, Lisp_Object);
/* Defined in data.c. */
extern bool symbols_with_pos_enabled;
extern AVOID args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object);
extern AVOID wrong_type_argument (Lisp_Object, Lisp_Object);
extern Lisp_Object default_value (Lisp_Object symbol);
@ -973,57 +998,12 @@ union vectorlike_header
ptrdiff_t size;
};
INLINE bool
(SYMBOLP) (Lisp_Object x)
struct Lisp_Symbol_With_Pos
{
return lisp_h_SYMBOLP (x);
}
INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
XSYMBOL (Lisp_Object a)
{
eassert (SYMBOLP (a));
intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol);
void *p = (char *) lispsym + i;
return p;
}
INLINE Lisp_Object
make_lisp_symbol (struct Lisp_Symbol *sym)
{
/* GCC 7 x86-64 generates faster code if lispsym is
cast to char * rather than to intptr_t. */
char *symoffset = (char *) ((char *) sym - (char *) lispsym);
Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset);
eassert (XSYMBOL (a) == sym);
return a;
}
INLINE Lisp_Object
builtin_lisp_symbol (int index)
{
return make_lisp_symbol (&lispsym[index]);
}
INLINE bool
c_symbol_p (struct Lisp_Symbol *sym)
{
char *bp = (char *) lispsym;
char *sp = (char *) sym;
if (PTRDIFF_MAX < INTPTR_MAX)
return bp <= sp && sp < bp + sizeof lispsym;
else
{
ptrdiff_t offset = sp - bp;
return 0 <= offset && offset < sizeof lispsym;
}
}
INLINE void
(CHECK_SYMBOL) (Lisp_Object x)
{
lisp_h_CHECK_SYMBOL (x);
}
union vectorlike_header header;
Lisp_Object sym; /* A symbol */
Lisp_Object pos; /* A fixnum */
} GCALIGNED_STRUCT;
/* In the size word of a vector, this bit means the vector has been marked. */
@ -1048,6 +1028,7 @@ enum pvec_type
PVEC_MARKER,
PVEC_OVERLAY,
PVEC_FINALIZER,
PVEC_SYMBOL_WITH_POS,
PVEC_MISC_PTR,
PVEC_USER_PTR,
PVEC_PROCESS,
@ -1107,6 +1088,92 @@ enum More_Lisp_Bits
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)
INLINE bool
PSEUDOVECTORP (Lisp_Object a, int code)
{
return lisp_h_PSEUDOVECTORP (a, code);
}
INLINE bool
(BARE_SYMBOL_P) (Lisp_Object x)
{
return lisp_h_BARE_SYMBOL_P (x);
}
INLINE bool
(SYMBOL_WITH_POS_P) (Lisp_Object x)
{
return lisp_h_SYMBOL_WITH_POS_P (x);
}
INLINE bool
(SYMBOLP) (Lisp_Object x)
{
return lisp_h_SYMBOLP (x);
}
INLINE struct Lisp_Symbol_With_Pos *
XSYMBOL_WITH_POS (Lisp_Object a)
{
eassert (SYMBOL_WITH_POS_P (a));
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos);
}
INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
(XBARE_SYMBOL) (Lisp_Object a)
{
eassert (BARE_SYMBOL_P (a));
intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol);
void *p = (char *) lispsym + i;
return p;
}
INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
(XSYMBOL) (Lisp_Object a)
{
eassert (SYMBOLP ((a)));
if (!symbols_with_pos_enabled || BARE_SYMBOL_P (a))
return XBARE_SYMBOL (a);
return XBARE_SYMBOL (XSYMBOL_WITH_POS (a)->sym);
}
INLINE Lisp_Object
make_lisp_symbol (struct Lisp_Symbol *sym)
{
/* GCC 7 x86-64 generates faster code if lispsym is
cast to char * rather than to intptr_t. */
char *symoffset = (char *) ((char *) sym - (char *) lispsym);
Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset);
eassert (XSYMBOL (a) == sym);
return a;
}
INLINE Lisp_Object
builtin_lisp_symbol (int index)
{
return make_lisp_symbol (&lispsym[index]);
}
INLINE bool
c_symbol_p (struct Lisp_Symbol *sym)
{
char *bp = (char *) lispsym;
char *sp = (char *) sym;
if (PTRDIFF_MAX < INTPTR_MAX)
return bp <= sp && sp < bp + sizeof lispsym;
else
{
ptrdiff_t offset = sp - bp;
return 0 <= offset && offset < sizeof lispsym;
}
}
INLINE void
(CHECK_SYMBOL) (Lisp_Object x)
{
lisp_h_CHECK_SYMBOL (x);
}
/* True if the possibly-unsigned integer I doesn't fit in a fixnum. */
@ -1238,7 +1305,14 @@ make_fixed_natnum (EMACS_INT n)
}
/* Return true if X and Y are the same object. */
INLINE bool
(BASE_EQ) (Lisp_Object x, Lisp_Object y)
{
return lisp_h_BASE_EQ (x, y);
}
/* Return true if X and Y are the same object, reckoning a symbol with
position as being the same as the bare symbol. */
INLINE bool
(EQ) (Lisp_Object x, Lisp_Object y)
{
@ -1704,21 +1778,6 @@ PSEUDOVECTOR_TYPEP (const union vectorlike_header *a, enum pvec_type code)
== (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS)));
}
/* True if A is a pseudovector whose code is CODE. */
INLINE bool
PSEUDOVECTORP (Lisp_Object a, int code)
{
if (! VECTORLIKEP (a))
return false;
else
{
/* Converting to union vectorlike_header * avoids aliasing issues. */
return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike,
union vectorlike_header),
code);
}
}
/* A boolvector is a kind of vectorlike, with contents like a string. */
struct Lisp_Bool_Vector
@ -2630,6 +2689,22 @@ XOVERLAY (Lisp_Object a)
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay);
}
INLINE Lisp_Object
SYMBOL_WITH_POS_SYM (Lisp_Object a)
{
if (!SYMBOL_WITH_POS_P (a))
wrong_type_argument (Qsymbol_with_pos_p, a);
return XSYMBOL_WITH_POS (a)->sym;
}
INLINE Lisp_Object
SYMBOL_WITH_POS_POS (Lisp_Object a)
{
if (!SYMBOL_WITH_POS_P (a))
wrong_type_argument (Qsymbol_with_pos_p, a);
return XSYMBOL_WITH_POS (a)->pos;
}
INLINE bool
USER_PTRP (Lisp_Object x)
{
@ -4061,6 +4136,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_symbol_with_pos (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);

139
src/lread.c
View file

@ -128,9 +128,8 @@ static ptrdiff_t read_from_string_index;
static ptrdiff_t read_from_string_index_byte;
static ptrdiff_t read_from_string_limit;
/* Number of characters read in the current call to Fread or
Fread_from_string. */
static EMACS_INT readchar_count;
/* Position in object from which characters are being read by `readchar'. */
static EMACS_INT readchar_offset;
/* This contains the last string skipped with #@. */
static char *saved_doc_string;
@ -213,7 +212,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte)
if (multibyte)
*multibyte = 0;
readchar_count++;
readchar_offset++;
if (BUFFERP (readcharfun))
{
@ -424,7 +423,7 @@ skip_dyn_eof (Lisp_Object readcharfun)
static void
unreadchar (Lisp_Object readcharfun, int c)
{
readchar_count--;
readchar_offset--;
if (c == -1)
/* Don't back up the pointer if we're unreading the end-of-input mark,
since readchar didn't advance it when we read it. */
@ -647,12 +646,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 *);
@ -2287,7 +2286,7 @@ readevalloop (Lisp_Object readcharfun,
Qnil, false);
if (!NILP (Vpurify_flag) && c == '(')
{
val = read_list (0, readcharfun);
val = read_list (0, readcharfun, false);
}
else
{
@ -2309,7 +2308,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)
@ -2467,7 +2466,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-positioning-symbols", Fread_positioning_symbols,
Sread_positioning_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 "symbol with pos" 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,
@ -2483,18 +2510,21 @@ 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 symbols with
position. */
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;
readchar_count = 0;
readchar_offset = BUFFERP (stream) ? XBUFFER (stream)->pt : 0;
/* We can get called from readevalloop which may have set these
already. */
if (! HASH_TABLE_P (read_objects_map)
@ -2530,7 +2560,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);
@ -2549,12 +2579,12 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end)
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;
@ -2978,10 +3008,12 @@ read_integer (Lisp_Object readcharfun, 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 symbols with
position. */
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;
@ -3001,10 +3033,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 ']':
@ -3023,7 +3055,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, false);
Lisp_Object head = CAR_SAFE (tmp);
Lisp_Object data = Qnil;
Lisp_Object val = Qnil;
@ -3112,7 +3144,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, false);
if (ASIZE (tmp) < CHAR_TABLE_STANDARD_SLOTS)
error ("Invalid size char-table");
XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE);
@ -3125,7 +3157,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, false);
ptrdiff_t size = list_length (tmp);
int i, depth, min_char;
struct Lisp_Cons *cell;
@ -3163,7 +3195,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, false);
c = READCHAR;
if (c == '"')
{
@ -3172,7 +3204,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, false);
if (STRING_MULTIBYTE (tmp)
|| (size_in_chars != SCHARS (tmp)
/* We used to print 1 char too many
@ -3200,7 +3232,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, false);
vec = XVECTOR (tmp);
if (! (COMPILED_STACK_DEPTH < ASIZE (tmp)
&& (FIXNUMP (AREF (tmp, COMPILED_ARGLIST))
@ -3233,7 +3265,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, false);
if (ch != 0 || !STRINGP (tmp))
invalid_syntax ("#", readcharfun);
/* Read the intervals and their properties. */
@ -3241,14 +3273,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, false);
end = plist = Qnil;
if (ch == ')')
break;
if (ch == 0)
end = read1 (readcharfun, &ch, 0);
end = read1 (readcharfun, &ch, 0, false);
if (ch == 0)
plist = read1 (readcharfun, &ch, 0);
plist = read1 (readcharfun, &ch, 0, false);
if (ch)
invalid_syntax ("Invalid string property list", readcharfun);
Fset_text_properties (beg, end, plist, tmp);
@ -3359,7 +3391,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 == ':')
{
@ -3442,7 +3474,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
hash_put (h, number, placeholder, hash);
/* Read the object itself. */
Lisp_Object tem = read0 (readcharfun);
Lisp_Object tem = read0 (readcharfun, locate_syms);
/* If it can be recursive, remember it for
future substitutions. */
@ -3498,6 +3530,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
else if (c == 'b' || c == 'B')
return read_integer (readcharfun, 2, stackbuf);
char acm_buf[15]; /* FIXME!!! 2021-11-27. */
sprintf (acm_buf, "#%c", c);
invalid_syntax (acm_buf, readcharfun);
UNREAD (c);
invalid_syntax ("#", readcharfun);
@ -3506,10 +3541,10 @@ 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 '`':
return list2 (Qbackquote, read0 (readcharfun));
return list2 (Qbackquote, read0 (readcharfun, locate_syms));
case ',':
{
@ -3525,7 +3560,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);
}
case '?':
@ -3727,7 +3762,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
char *p = read_buffer;
char *end = read_buffer + read_buffer_size;
bool quoted = false;
EMACS_INT start_position = readchar_count - 1;
EMACS_INT start_position = readchar_offset - 1;
do
{
@ -3832,6 +3867,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
result = intern_driver (name, obarray, tem);
}
}
if (locate_syms
&& !NILP (result)
)
result = build_symbol_with_pos (result,
make_fixnum (start_position));
if (EQ (Vread_with_symbol_positions, Qt)
|| EQ (Vread_with_symbol_positions, readcharfun))
@ -4090,9 +4130,9 @@ 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)
{
Lisp_Object tem = read_list (1, readcharfun);
Lisp_Object tem = read_list (1, readcharfun, locate_syms);
ptrdiff_t size = list_length (tem);
Lisp_Object vector = make_nil_vector (size);
@ -4164,10 +4204,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 symbols with
position. */
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;
@ -4185,7 +4227,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;
@ -4211,10 +4253,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 == ')')
{
@ -5090,6 +5132,7 @@ void
syms_of_lread (void)
{
defsubr (&Sread);
defsubr (&Sread_positioning_symbols);
defsubr (&Sread_from_string);
defsubr (&Slread__substitute_object_in_subtree);
defsubr (&Sintern);

33
src/print.c
View file

@ -1649,6 +1649,30 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
printchar ('>', printcharfun);
break;
case PVEC_SYMBOL_WITH_POS:
{
struct Lisp_Symbol_With_Pos *sp = XSYMBOL_WITH_POS (obj);
if (print_symbols_bare)
print_object (sp->sym, printcharfun, escapeflag);
else
{
print_c_string ("#<symbol ", printcharfun);
if (BARE_SYMBOL_P (sp->sym))
print_object (sp->sym, printcharfun, escapeflag);
else
print_c_string ("NOT A SYMBOL!!", printcharfun);
if (FIXNUMP (sp->pos))
{
print_c_string (" at ", printcharfun);
print_object (sp->pos, printcharfun, escapeflag);
}
else
print_c_string (" NOT A POSITION!!", printcharfun);
printchar ('>', printcharfun);
}
}
break;
case PVEC_OVERLAY:
print_c_string ("#<overlay ", printcharfun);
if (! XMARKER (OVERLAY_START (obj))->buffer)
@ -1974,7 +1998,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
error ("Apparently circular structure being printed");
for (i = 0; i < print_depth; i++)
if (EQ (obj, being_printed[i]))
if (BASE_EQ (obj, being_printed[i]))
{
int len = sprintf (buf, "#%d", i);
strout (buf, len, len, printcharfun);
@ -2478,6 +2502,13 @@ priorities. Values other than nil or t are also treated as
`default'. */);
Vprint_charset_text_property = Qdefault;
DEFVAR_BOOL ("print-symbols-bare", print_symbols_bare,
doc: /* A flag to control printing of symbols with position.
If the value is nil, print these objects complete with position.
Otherwise print just the bare symbol. */);
print_symbols_bare = false;
DEFSYM (Qprint_symbols_bare, "print-symbols-bare");
/* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
staticpro (&Vprin1_to_string_buffer);