[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/positioned-lambdas 569fc297b85 1/3: Use ; POS... position inform
|
From: |
Alan Mackenzie |
|
Subject: |
feature/positioned-lambdas 569fc297b85 1/3: Use ; POS... position information in backtraces |
|
Date: |
Sun, 10 Mar 2024 14:53:04 -0400 (EDT) |
branch: feature/positioned-lambdas
commit 569fc297b850d1b9bf4ad0d022d20822988fbb57
Author: Alan Mackenzie <acm@muc.de>
Commit: Alan Mackenzie <acm@muc.de>
Use ;POS... position information in backtraces
Also code up adding this information for defvars, defconsts,
and cl-defmethods. This is progress on bug #67455.
* lisp/emacs-lisp/byte-run.el (byte-run-position-vec): New
function.
(byte-run--fun-put-new-string): Tidy up the coding.
(byte-run-posify-existing-defaliases-1): Actually fset the
result to the pertinent symbol.
(byte-run-posify-existing-defvars/consts-1)
(byte-run-posify-existing-defvars/consts): New functions.
* lisp/emacs-lisp/bytecomp.el: Remove commented out old code.
* lisp/emacs-lisp/cl-generic.el (cl-defmethod): Insert the
;POS... structure into the form being defined, but using
explicit code rather than the (defining-symbol ...) declare
clause. Add a byte-run-defined-form property to cl-defmethod
so the reader will position the generated symbols.
* lisp/emacs-lisp/cl-print.el (cl-print-object/cons): On
encountering a lambda or closure form, print the defining
symbol in braces.
(cl-print-object/compiled-function): Print the defining symbol
in braces.
* lisp/emacs-lisp/comp.el (comp-intern-func-in-ctxt): Pass
`also-pos' to `documentation' to get the doc's
;POS... information too.
* lisp/emacs-lisp/macroexp.el (macroexp--expand-all): Add code
to the defvar/defconst pcase arm to set `defining-symbol' to
the var/const being defined, and to strip the position from
that symbol.
* lisp/loadup.el: Set symbols-with-pos-enabled to t sooner.
Call the new function byte-run-posify-existing-defvars/consts
to posify variables/constants defined early in the boot
process.
* lisp/startup.el (normal-top-level): Set `debug' to debugger
for interactive sessions.
* src/data.c (syms_of_data): Give `defalias' a
byte-run-defined-form propery of 1, so that the reader will
position the symbol it defines.
* src/eval.c (Finternal__define_uninitialized_variable): Posify
the doc string argument, or give the symbol a
byte-run--early-defvar-const property early in the boot
procedure.
(handle_defvar_defconst_positions): New function.
(Fmacroexpand): Call the above function for a defvar/defconst.
(eval_sub): Also call the new function for a defvar/defconst.
(syms_of_eval): Declare two new symbols in byte-run.el. Give
`defvar' and `defconst' byte-run-defined-form properties so as
to trigger the reader to position new symbols.
---
lisp/emacs-lisp/byte-run.el | 69 +++++++++++++++++++-----
lisp/emacs-lisp/bytecomp.el | 119 ++----------------------------------------
lisp/emacs-lisp/cl-generic.el | 27 ++++++++--
lisp/emacs-lisp/cl-print.el | 27 ++++++++--
lisp/emacs-lisp/comp.el | 2 +-
lisp/emacs-lisp/macroexp.el | 10 ++--
lisp/loadup.el | 10 ++--
lisp/startup.el | 5 ++
src/data.c | 1 +
src/doc.c | 4 +-
src/eval.c | 36 +++++++++++++
src/lread.c | 4 +-
12 files changed, 166 insertions(+), 148 deletions(-)
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 846c383094a..8b98290609e 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -188,7 +188,7 @@ This is done by destructively modifying ARG. Return ARG."
(puthash a t byte-run--ssp-seen)
(cond
((symbol-with-pos-p (car a))
- (message "SWP in %S, %S" name (car a)))
+ (message "SWP(1) in %S, %S" name (car a)))
((consp (car a))
(byte-run--report-list name (car a)))
((or (vectorp (car a)) (recordp (car a)))
@@ -199,7 +199,7 @@ This is done by destructively modifying ARG. Return ARG."
(setq a (cdr a)))
(cond
((symbol-with-pos-p (cdr a))
- (message "SWP in %S, %S" name (cdr a)))
+ (message "SWP(2) in %S, %S" name (cdr a)))
;; ((or (vectorp (cdr a)) (recordp (cdr a)))
;; (byte-run--strip-vector/record (cdr a)))
)
@@ -214,7 +214,7 @@ record, containing symbols with position."
(setq byte-run--ssp-seen (make-hash-table :test 'eq))
(cond
((symbol-with-pos-p arg)
- (message "SWP in %S, %S" name arg))
+ (message "SWP(3) in %S, %S" name arg))
((consp arg)
(byte-run--report-list name arg))
((or (vectorp arg) (recordp arg))
@@ -522,6 +522,15 @@ unchanged."
doc-string
))))))
+(defalias 'byte-run-position-vec
+ #'(lambda (doc-string)
+ "Extract the position information, if any, from DOC-STRING.
+This will be returned as a four element vector, or nil if there is
+no position information in DOC-STRING."
+ (and (stringp doc-string)
+ (string-match "\\`;POS\036\001\001\001 \\[" doc-string)
+ (read (substring doc-string (1- (match-end 0)))))))
+
(defalias 'byte-run-posify-lambda-form
#'(lambda (form position)
"Put position structure on the lambda form FORM.
@@ -1130,7 +1139,7 @@ and MAC is `macro' if additionally FUN is a macro, else
nil.
If it's something else, return nil."
(if (consp fun)
- (let ((mac (and (eq (car-safe fun) 'macro) 'macro)))
+ (let ((mac (and (eq (car fun) 'macro) 'macro)))
(if (eq mac 'macro)
(setq fun (cdr fun)))
(if (consp fun)
@@ -1160,13 +1169,16 @@ Create and return a new form rather than altering the
old one."
(if (cdr doc-pos/m)
(setq fun (cdr fun)))
(let* ((doc-pos (car doc-pos/m))
- (insert (null (stringp (nth doc-pos fun)))))
- (nconc (take doc-pos fun)
- (list doc-string)
- (nthcdr (if insert doc-pos (1+ doc-pos)) fun))))
+ (insert (null (stringp (nth doc-pos fun))))
+ (form (append (take doc-pos fun)
+ (list doc-string)
+ (nthcdr (if insert doc-pos (1+ doc-pos)) fun))))
+ (if (cdr doc-pos/m)
+ (cons 'macro form)
+ form)))
(defun byte-run--fun-get-lambda-pos (fun doc-pos/m)
- "Get the position (if any) of the lambda symbol from FUN.
+ "Get the position (if any) from the lambda symbol in FUN.
FUN is a function form, DOC-POS/M is a cons of FUN's DOC-POS and
whether it's a macro.
@@ -1207,18 +1219,49 @@ no characters other than the POS info, return nil
instead."
(old-doc-string (byte-run--fun-get-string fun doc-pos/m))
(bare-doc-string (byte-run-strip-pos-info old-doc-string))
(new-doc-string (byte-run-posify-doc-string bare-doc-string
- lambda-pos)))
- (byte-run--fun-put-new-string fun new-doc-string
doc-pos/m)))))))
+ lambda-pos))
+ (new-fun (byte-run--fun-put-new-string fun new-doc-string
+ doc-pos/m)))
+ (fset sym new-fun)))))))
(defun byte-run-posify-existing-defaliases ()
"Create the position structure in the doc strings of existing functions.
-At the same time, strip the positions from the defining symbol and the
-lambda."
+Do not strip the positions from the defining symbol or the lambda."
;; This function should be run with `symbols-with-pos-enabled'
;; non-nil. We can't use a lambda form here, since it would have a
;; position on the lambda symbol.
(mapatoms #'byte-run-posify-existing-defaliases-1))
+(defun byte-run-posify-existing-defvars/consts-1 (sym)
+ "Sub function of `byte-run-posify-existing-defvars/consts'."
+ (if (get sym 'byte-run--early-defvar-const)
+ (let* ((defining-symbol (get sym 'byte-run--early))
+ (doc-string (get sym 'variable-documentation))
+ (plist (symbol-plist sym))
+ (ptr plist)
+ ;; (tail (memq 'byte-run--early-defvar-const plist))
+ )
+ (if (or (stringp doc-string) (null doc-string))
+ (progn
+ (setq doc-string (byte-run-posify-doc-string doc-string))
+ (put sym 'variable-documentation doc-string)))
+ ;; Remove the property from the property list so that the symbol
+ ;; with pos doesn't later hinder the dumping process.
+ (if (eq (car plist) 'byte-run--early-defvar-const)
+ (progn
+ (setplist sym (cdr (cdr plist))))
+ (while (and ptr
+ (null (eq (car (cdr (cdr ptr)))
+ 'byte-run--early-defvar-const)))
+ (setq ptr (cdr (cdr ptr))))
+ (if ptr
+ (setcdr (cdr ptr) (cdr (cdr (cdr (cdr ptr))))))))))
+
+(defun byte-run-posify-existing-defvars/consts ()
+ "Create the position structure in the doc strings of existing defvars.
+Also defconsts. Do not strip the positions from the symbols."
+ (mapatoms #'byte-run-posify-existing-defvars/consts-1))
+
(defun byte-run-posify-existing-lambdas ()
"Create the position structure in the doc strings of existing lambdas.
At the same time, strip the positions from the defining symbol and
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index c7e82cb3ccd..b936cfb4a1f 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -1769,37 +1769,6 @@ It is too wide if it has any lines longer than the
largest of
(prefix (lambda ()
(format "%s%s"
kind
-;;;; Merge STOUGH, 2024-03-03
-;; <<<<<<< HEAD
-;; (if name (format-message " `%s' " name) "")))))
-;; (pcase (car form)
-;; ((or 'autoload 'custom-declare-variable 'defalias
-;; 'defconst 'define-abbrev-table
-;; 'defvar 'defvaralias
-;; 'custom-declare-face)
-;; (setq kind (nth 0 form))
-;; (setq name (nth 1 form))
-;; (when (and (consp name) (eq (car name) 'quote))
-;; (setq name (cadr name)))
-;; (setq docs (nth 3 form)))
-;; ('lambda
-;; (setq kind "") ; can't be "function", unfortunately
-;; (setq docs (nth 2 form))))
-;; (when (and kind docs (stringp docs)
-;; (setq docs (help-strip-pos-info docs)))
-;; (let ((col (max byte-compile-docstring-max-column fill-column)))
-;; (when (and (byte-compile-warning-enabled-p 'docstrings-wide)
-;; (byte-compile--wide-docstring-p docs col))
-;; (byte-compile-warn-x
-;; name
-;; "%sdocstring wider than %s characters" (funcall prefix) col)))
-;; ;; There's a "naked" ' character before a symbol/list, so it
-;; ;; should probably be quoted with \=.
-;; (when (string-match-p (rx (| (in " \t") bol)
-;; (? (in "\"#"))
-;; "'"
-;; (in "A-Za-z" "("))
-;; =======
(if name (format-message " `%S' " name) "")))))
(let ((col (max byte-compile-docstring-max-column fill-column)))
(when (and (byte-compile-warning-enabled-p 'docstrings-wide)
@@ -1824,7 +1793,6 @@ It is too wide if it has any lines longer than the
largest of
(when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes)
(when (string-match-p (rx (| " \"" (in " \t") bol)
(in "‘’"))
-;; >>>>>>> master
docs)
(byte-compile-warn-x
name
@@ -2665,31 +2633,7 @@ Call from the source buffer."
(push sym byte-compile--seen-defvars))
(defun byte-compile-file-form-defvar (form)
-;;;; MERGED AWAY STOUGH, 2024-03-03
-;; <<<<<<< HEAD
-;; (let* ((sym (nth 1 form))
-;; (defining-symbol sym))
-;; (byte-compile--declare-var sym)
-;; (if (eq (car form) 'defconst)
-;; (push sym byte-compile-const-variables))
-;; (if (and (null (cddr form)) ;No `value' provided.
-;; (eq (car form) 'defvar)) ;Just a declaration.
-;; nil
-;; (byte-compile-docstring-style-warn form)
-;; (setq form (copy-sequence form))
-;; (when (consp (nth 2 form))
-;; (setcar (cdr (cdr form))
-;; (byte-compile-top-level (nth 2 form) nil 'file)))
-;; (let ((posified-doc-string
-;; (byte-run-posify-doc-string
-;; (and (nth 3 form) (stringp (nth 3 form)) (nth 3 form)))))
-;; (if (nthcdr 3 form)
-;; (setcar (nthcdr 3 form) posified-doc-string)
-;; (nconc form (list posified-doc-string))))
-;; form)))
-;; =======
(byte-compile-defvar form 'toplevel))
-;; >>>>>>> master
(put 'define-abbrev-table 'byte-hunk-handler
'byte-compile-file-form-defvar-function)
@@ -2896,24 +2840,9 @@ not to take responsibility for the actual compilation of
the code."
(make-byte-to-native-func-def :name name
:byte-func code))
byte-to-native-top-level-forms))
-;;;; OLD STOUGH, 2024-03-03
-;; <<<<<<< HEAD
-;; ;; Output the form by hand, that's much simpler than having
-;; ;; b-c-output-file-form analyze the defalias.
-;; (byte-compile-output-docform
-;; "\n(defalias '" ")"
-;; bare-name
-;; (if macro '(" '(macro . #[" "])") '(" #[" "]"))
-;; (append code nil) ; Turn byte-code-function-p into list.
-;; 2 4
-;; (and (atom code) byte-compile-dynamic 1)
-;; nil)
-;; t)))))
-;;=======
(let ((byte-native-compiling nil))
(byte-compile-output-file-form newform)))
t))))
-;; >>>>>>> master
(defun byte-compile-output-as-comment (exp quoted)
"Print Lisp object EXP in the output file at point, inside a comment.
@@ -2983,44 +2912,6 @@ If FORM is a lambda or a macro, byte-compile it as a
function."
(fun (if (symbolp form)
(symbol-function form)
form))
-;;;; MERGE STOUGH, 2024-03-03
-;; <<<<<<< HEAD
-;; (macro (eq (car-safe fun) 'macro)))
-;; (if macro
-;; (setq fun (cdr fun)))
-;; (prog1
-;; (cond
-;; ;; Up until Emacs-24.1, byte-compile silently did nothing
-;; ;; when asked to compile something invalid. So let's tone
-;; ;; down the complaint from an error to a simple message for
-;; ;; the known case where signaling an error causes problems.
-;; ((compiled-function-p fun)
-;; (message "Function %s is already compiled"
-;; (if (symbolp form) form "provided"))
-;; fun)
-;; (t
-;; (let (final-eval defining-symbol)
-;; (when (or (symbolp form) (eq (car-safe fun) 'closure))
-;; ;; `fun' is a function *value*, so try to recover its
corresponding
-;; ;; source code.
-;; (setq lexical-binding (eq (car fun) 'closure))
-;; (setq fun (byte-compile--reify-function fun))
-;; (setq final-eval t))
-;; ;; Expand macros.
-;; (setq fun (byte-compile-preprocess fun))
-;; (setq fun (byte-compile-top-level fun nil 'eval))
-;; (if (symbolp form)
-;; ;; byte-compile-top-level returns an *expression*
equivalent to the
-;; ;; `fun' expression, so we need to evaluate it, tho
normally
-;; ;; this is not needed because the expression is just a
constant
-;; ;; byte-code object, which is self-evaluating.
-;; (setq fun (eval fun t)))
-;; (if final-eval
-;; (setq fun (eval fun t)))
-;; (if macro (push 'macro fun))
-;; (if (symbolp form) (fset form fun))
-;; fun))))))))
-;; =======
(macro (eq (car-safe fun) 'macro))
(need-a-value nil))
(when macro
@@ -3054,7 +2945,6 @@ If FORM is a lambda or a macro, byte-compile it as a
function."
(if macro (push 'macro fun))
(if (symbolp form) (fset form fun))
fun))))))
-;; >>>>>>> master
(defun byte-compile-sexp (sexp)
"Compile and return SEXP."
@@ -5135,9 +5025,7 @@ binding slots have been popped."
string
"third arg to `%s %s' is not a string: %s"
fun var string)))
-;;;; NEW STOUGH FROM MERGE, 2024-02-24
(setq string (byte-run-posify-doc-string (and (stringp string) string)))
-;;;; END OF NEW STOUGH
(if toplevel
;; At top-level we emit calls to defvar/defconst.
(if (and (null (cddr form)) ;No `value' provided.
@@ -5206,8 +5094,11 @@ binding slots have been popped."
(pcase-let*
;; `macro' is non-nil if it defines a macro.
;; `fun' is the function part of `arg' (defaults to `arg').
- (((or (and (or `(cons 'macro ,fun) `'(macro . ,fun)) (let macro t))
- (and (let fun arg) (let macro nil)))
+ (((or (and (or `(cons 'macro ,fun)
+ `'(macro . ,fun))
+ (let macro t))
+ (and (let fun arg)
+ (let macro nil)))
arg)
;; `lam' is the lambda expression in `fun' (or nil if not
;; recognized).
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 63a1347d7e2..1168d8e3184 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -565,9 +565,10 @@ The set of acceptable TYPEs (also called \"specializers\")
is defined
\(fn NAME [EXTRA] [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
(declare (doc-string cl--defmethod-doc-pos) (indent defun)
- ;; Because there are a variable number of parameters preceding
- ;; any doc string, it is currently not possible to code a
- ;; defining-symbol clause. ACM, 2024-03-02.
+ ;; Because there are a variable number of parameters
+ ;; preceding any doc string, it is not practiable to code a
+ ;; defining-symbol clause. Instead we code the procedure
+ ;; explicitly in this function. ACM, 2023-03-09.
(debug
(&define ; this means we are defining something
[&name [sexp ;Allow (setf ...) additionally to symbols.
@@ -584,6 +585,25 @@ The set of acceptable TYPEs (also called \"specializers\")
is defined
(require 'gv)
(declare-function gv-setter "gv" (name))
(setq name (gv-setter (cadr name))))
+
+ (setq defining-symbol name)
+ (let* ((old-ds
+ (or (and (stringp (car body)) (car body))
+ (and (eq (car-safe (car body)) ':documentation)
+ (car body))))
+ (new-ds (byte-run-posify-doc-string old-ds)))
+ (setq body
+ (cond
+ ;; Doc string supplied and non-null (cdr body).
+ ((and old-ds (cdr body))
+ (cons new-ds (cdr body)))
+ ;; Doc string supplied but no further body.
+ (old-ds (list new-ds old-ds))
+ ;; Neither doc string nor body.
+ ((null body) (list new-ds 'nil))
+ ;; No doc string but body.
+ (t (cons new-ds body)))))
+
(pcase-let* ((`(,call-con . ,fun) (cl--generic-lambda args body)))
`(progn
;; You could argue that `defmethod' modifies rather than defines the
@@ -596,6 +616,7 @@ The set of acceptable TYPEs (also called \"specializers\")
is defined
;; obsolescence warning when applicable.
(cl-generic-define-method #',name ',(nreverse qualifiers) ',args
',call-con ,fun)))))
+(put 'cl-defmethod 'byte-run-defined-form 1)
(defun cl--generic-member-method (specializers qualifiers methods)
(while
diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index c35353ec3d0..4d40c3e0778 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -66,6 +66,15 @@ Print the contents hidden by the ellipsis to STREAM."
(error "Missing cl-print-object-contents method"))
(cl-defmethod cl-print-object ((object cons) stream)
+ (when (memq (car object) '(lambda closure))
+ (let* ((doc-string (documentation object 'also-pos))
+ (pos-info (byte-run-position-vec doc-string))
+ (defsym (and (vectorp pos-info)
+ (aref pos-info 0))))
+ (when defsym
+ (princ "{" stream)
+ (prin1 defsym stream)
+ (princ "} " stream))))
(if (and cl-print--depth (natnump print-level)
(> cl-print--depth print-level))
(cl-print-insert-ellipsis object nil stream)
@@ -183,11 +192,19 @@ into a button whose action shows the function's
disassembly.")
(cl-defmethod cl-print-object ((object compiled-function) stream)
(unless stream (setq stream standard-output))
;; We use "#f(...)" rather than "#<...>" so that pp.el gives better results.
- (princ "#f(compiled-function " stream)
- (let ((args (help-function-arglist object 'preserve-names)))
+ (let* ((args (help-function-arglist object 'preserve-names))
+ (doc-string (documentation object 'also-pos))
+ (pos-info (byte-run-position-vec doc-string))
+ (defsym (and (vectorp pos-info)
+ (aref pos-info 0))))
+ (when defsym
+ (princ "{" stream)
+ (prin1 defsym stream)
+ (princ "} " stream))
+ (princ "#f(compiled-function " stream)
(if args
(prin1 args stream)
- (princ "()" stream)))
+ (princ "()" stream))
(if (eq cl-print-compiled 'raw)
(let ((button-start
(and cl-print-compiled-button
@@ -200,7 +217,7 @@ into a button whose action shows the function's
disassembly.")
(make-text-button button-start (point)
:type 'help-byte-code
'byte-code-function object))))
- (pcase (help-split-fundoc (documentation object 'raw) object)
+ (pcase (help-split-fundoc doc-string object)
;; Drop args which `help-function-arglist' already printed.
(`(,_usage . ,(and doc (guard (stringp doc))))
(princ " " stream)
@@ -214,7 +231,7 @@ into a button whose action shows the function's
disassembly.")
(nth 2 (cadr inter))
(nth 3 (cadr inter))))
inter)
- stream)))
+ stream))))
(if (eq cl-print-compiled 'disassemble)
(princ
(with-temp-buffer
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 431d2aaf918..1203d72e41c 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -784,7 +784,7 @@ clashes."
(make-comp-func-d :lambda-list (aref byte-func 0)))))
(setf (comp-func-name func) name
(comp-func-byte-func func) byte-func
- (comp-func-doc func) (documentation byte-func t)
+ (comp-func-doc func) (documentation byte-func 'also-pos)
(comp-func-int-spec func) (interactive-form byte-func)
(comp-func-command-modes func) (command-modes byte-func)
(comp-func-c-name func) c-name
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index e55eb72b985..f53fac6680c 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -406,9 +406,13 @@ Assumes the caller has bound
`macroexpand-all-environment'."
(macroexp-warn-and-return
(format-message "`condition-case' without handlers")
exp-body (list 'suspicious 'condition-case) t form))))
- (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_)
- (push name macroexp--dynvars)
- (macroexp--all-forms form 2))
+ (`(,(and sf (or 'defvar 'defconst))
+ ,(and name (pred symbolp)) . ,rest)
+ (push (bare-symbol name) macroexp--dynvars)
+ (if (and (null defining-symbol)
+ (symbol-with-pos-p name))
+ (setq defining-symbol name))
+ (macroexp--all-forms (cons sf (cons (bare-symbol name) rest)) 2))
(`(function ,(and f `(lambda ,_ . ,_)))
(progn
(let ((macroexp--dynvars macroexp--dynvars))
diff --git a/lisp/loadup.el b/lisp/loadup.el
index f2f0897853c..e25b2d7ed8a 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -112,6 +112,8 @@
(message "Using load-path %s" load-path)
+(setq symbols-with-pos-enabled t)
+
(if dump-mode
(progn
;; To reduce the size of dumped Emacs, we avoid making huge char-tables.
@@ -125,12 +127,12 @@
(setq buffer-undo-list t)
(defvar real-defvar (symbol-function 'defvar))
-(setq symbols-with-pos-enabled t)
(fset 'defvar (symbol-function 'defvar-bootstrap))
(load "emacs-lisp/debug-early")
(load "emacs-lisp/byte-run")
(byte-run-posify-existing-defaliases)
(byte-run-posify-existing-lambdas)
+(byte-run-posify-existing-defvars/consts)
;; (makunbound 'early-lambda-lists)
(setq early-lambda-lists nil) ; We don't want its symbols with
; position in the dumped image.
@@ -177,10 +179,6 @@
(load "emacs-lisp/debug-early")
(load "emacs-lisp/byte-run")
(message "loadup.el, just after second load of byte-run.el.")
-(message "loadup.el. base-loaded %S bound."
- (if (boundp 'base-loaded) "is" "isn't"))
-(message "loadup.el. base-loaded %S a SWP. symbols-with-pos-enabled is %S"
- (symbol-with-pos-p 'base-loaded) symbols-with-pos-enabled)
(message "loadup.el, just after setting base-loaded to t")
(unintern 'base-loaded nil) ; So that it can't be messed with from Lisp.
(load "emacs-lisp/backquote")
@@ -238,7 +236,7 @@
(setq plist (delq 'function-history plist))
(setplist elt plist))))))
(fset 'defvar real-defvar)
-(message "Just after (fset defvar real-defvar)")
+(message "Just after (fset 'defvar real-defvar)")
(setq symbols-with-pos-enabled nil)
(message "Just after setting symbols-with-pos-enabled back to nil")
diff --git a/lisp/startup.el b/lisp/startup.el
index 773765a4b97..0a2ab7011b3 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -565,6 +565,11 @@ On Android, Emacs uses this variable internally at
startup.")
It sets `command-line-processed', processes the command-line,
reads the initialization files, etc.
It is the default value of the variable `top-level'."
+ ;; Set the debugger to `debug' only for interactive sessions, otherwise
+ ;; leave it with `debug-early'.
+ (if (null noninteractive)
+ (setq debugger #'debug))
+
;; Initialize the Android font driver late.
;; This is done here because it needs the `mac-roman' coding system
;; to be loaded.
diff --git a/src/data.c b/src/data.c
index 755c49f0272..a66d387cb1f 100644
--- a/src/data.c
+++ b/src/data.c
@@ -4311,6 +4311,7 @@ syms_of_data (void)
defsubr (&Sfboundp);
defsubr (&Sfset);
defsubr (&Sdefalias);
+ Fput (Qdefalias, Qbyte_run_defined_form, make_fixnum (1));
defsubr (&Ssetplist);
defsubr (&Ssymbol_value);
defsubr (&Sset);
diff --git a/src/doc.c b/src/doc.c
index 45028ebe8c0..bf034a83037 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -374,7 +374,9 @@ OBJECT can be either a string or a reference if it's kept
externally. */)
DEFUN ("documentation", Fdocumentation, Sdocumentation, 1, 2, 0,
doc: /* Return the documentation string of FUNCTION.
Unless a non-nil second argument RAW is given, the
-string is passed through `substitute-command-keys'. */)
+string is passed through `substitute-command-keys'
+Any position information at the start of the doc string
+is removed unless RAW is the symbol `also-pos'. */)
(Lisp_Object function, Lisp_Object raw)
{
Lisp_Object doc;
diff --git a/src/eval.c b/src/eval.c
index 23beff2ee30..4c69d13560f 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -746,6 +746,12 @@ value. */)
symbol);
XSYMBOL (symbol)->u.s.declared_special = true;
+ /* The original symbol with position of `symbol' will be in
+ `defining-symbol'. */
+ if (Ffboundp (Qbyte_run_posify_doc_string))
+ doc = call2 (Qbyte_run_posify_doc_string, doc, Qnil);
+ else
+ Fput (symbol, Qbyte_run__early_defvar_const, Vdefining_symbol);
if (!NILP (doc))
{
if (!NILP (Vpurify_flag))
@@ -1153,6 +1159,24 @@ is not displayed. */)
return unbind_to (count, result);
}
+/* We must strip the positions from `defvar' and `defconst'
+ here, if any. */
+static Lisp_Object handle_defvar_defconst_positions (Lisp_Object form)
+{
+ Lisp_Object sym = (XCAR (form));
+
+ if (!byte_compile_in_progress
+ && (EQ (sym, Qdefvar) || EQ (sym, Qdefconst))
+ && Fsymbol_with_pos_p (Fcar_safe (Fcdr_safe (form))))
+ {
+ if (NILP (Vdefining_symbol))
+ Vdefining_symbol = XCAR (XCDR (form));
+ form = Fcons (sym, Fcons (Fbare_symbol (XCAR (XCDR (form))),
+ XCDR (XCDR (form))));
+ }
+ return form;
+}
+
DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0,
doc: /* Return result of expanding macros at top level of FORM.
If FORM is not a macro call, it is returned unchanged.
@@ -1206,6 +1230,10 @@ definitions to shadow the loaded ones for use in file
byte-compilation. */)
form = list2 (Qfunction, form);
break;
}
+ else
+ /* We must strip the positions from `defvar' and `defconst'
+ here, if any. */
+ form = handle_defvar_defconst_positions (form);
/* Look at its function definition. */
def = Fautoload_do_load (def, sym, Qmacro);
if (!CONSP (def))
@@ -2496,6 +2524,8 @@ eval_sub (Lisp_Object form)
xsignal1 (Qexcessive_lisp_nesting, make_fixnum (lisp_eval_depth));
}
+ form = handle_defvar_defconst_positions (form);
+
Lisp_Object original_fun = XCAR (form);
Lisp_Object original_args = XCDR (form);
CHECK_LIST (original_args);
@@ -4337,6 +4367,8 @@ before making `inhibit-quit' nil. */);
DEFSYM (Qdebug, "debug");
DEFSYM (Qdebug_early, "debug-early");
DEFSYM (Qdebug_early__handler, "debug-early--handler");
+ DEFSYM (Qbyte_run_posify_doc_string, "byte-run-posify-doc-string");
+ DEFSYM (Qbyte_run__early_defvar_const, "byte-run--early-defvar-const");
DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger,
doc: /* Non-nil means never enter the debugger.
@@ -4498,6 +4530,10 @@ alist of active lexical bindings. */);
defsubr (&Sdefault_toplevel_value);
defsubr (&Sset_default_toplevel_value);
defsubr (&Sdefvar);
+ DEFSYM (Qdefvar, "defvar");
+ Fput (Qdefvar, Qbyte_run_defined_form, make_fixnum (1));
+ DEFSYM (Qdefconst, "defconst");
+ Fput (Qdefconst, Qbyte_run_defined_form, make_fixnum (1));
defsubr (&Sdefvar_bootstrap);
defsubr (&Sdefvar_1);
defsubr (&Sdefvaralias);
diff --git a/src/lread.c b/src/lread.c
index 0952b2b9fbb..f35463130a5 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -6262,8 +6262,8 @@ For internal use only. */);
DEFVAR_LISP ("early-lambda-lists", Vearly_lambda_lists,
doc: /* List of details about early lambda forms.
Each element is a triple, (FORM, LAMBDA, DEFINING-SYMBOL) where the latter two
-are (usually) symbols with position, with which the lambda a FORM will be
-later positioned. */);
+are (usually) symbols with position, with which the lambda FORM will be later
+positioned. */);
Vearly_lambda_lists = Qnil;
DEFSYM (Qdefalias, "defalias");