mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-02-16 17:24:23 +00:00
Load backquote.el before byte-run.el.
This is to allow the many functions with "hand expanded backquotes" to use actual backquotes. Also make a few miscellaneous amendments, particularly to the test suite. * lisp/emacs-lisp/backquote.el (backquote-list*-function) (backquote-list*-macro, backquote, backquote-delay-process) (backquote-process, backquote-listify): Replace the declaring `defun's and `defmacros' with defalias. (Random places in the file): Replace `not' with `null', `push' with `setq' and `cons', and `unless' with `if' and `null'. * lisp/emacs-lisp/backtrace.el (backtrace--to-string): Use cl-prin1 rather than prin1. * lisp/emacs-lisp/byte-run.el (byte-run--posify-def-form): Remove. (byte-run--posify-list): No longer posify defining forms. (byte-run-posify-all-lambdas-etc) Rename by removing the "-etc" and no longer posify defining-forms. (byte-run--set-advertised-calling-convention) (byte-run--set-obsolete, byte-run--set-interactive-only) (byte-run--set-pure, byte-run--set-side-effect-free) (byte-run--set-important-return-value) (byte-run--set-doc-string, byte-run--set-indent) (byte-run--set-speed, byte-run--set-safety) (byte-run--set-completion, byte-run--set-modes) (byte-run--set-interactive-args) (byte-run--posify-defining-form, byte-run--set-function-type) (byte-run--set-debug, byte-run--set-no-font-lock-keyword) (defmacro, defun, dont-compile, eval-when-compile) (eval-and-compile): Recode using the backquote macro. * lisp/emacs-lisp/cl-generic.el (cl-defmethod): Remove the obtrusive car of the function which is the cdr of the return value from the byte-run-defined-form property value of this function. * lisp/emacs-lisp/macroexp.el (macroexp--expand-all): In the handling of quoted forms, no longer test byte-compile-in-progress. * lisp/loadup.el (top level) load backquote.el before byte-run.el. * test/lisp/emacs-lisp/backtrace-tests.el (backtrace-tests--forward-frame) * test/lisp/emacs-lisp/cconv-tests.el (cconv-convert-lambda-lifted, cconv-closure-convert-remap-var) (cconv-tests-interactive-form-modify-bug60974) * test/lisp/erc/erc-tests.el (erc--with-dependent-type-match): Use byte-run-strip-lambda-doc to prevent mismatches in comparisons caused by the presence of position information in doc strings.
This commit is contained in:
Alan Mackenzie
parent
7cc20b5d7f
commit
eb89a6c445
9 changed files with 275 additions and 368 deletions
|
|
@ -40,7 +40,8 @@
|
|||
|
||||
;; function and macro versions of backquote-list*
|
||||
|
||||
(defun backquote-list*-function (first &rest list)
|
||||
(defalias 'backquote-list*-function
|
||||
#'(lambda (first &rest list)
|
||||
"Like `list' but the last argument is the tail of the new list.
|
||||
|
||||
For example (backquote-list* \\='a \\='b \\='c) => (a b . c)"
|
||||
|
|
@ -55,9 +56,11 @@ For example (backquote-list* \\='a \\='b \\='c) => (a b . c)"
|
|||
rest (cdr rest)))
|
||||
(setcdr last (car rest))
|
||||
newlist)
|
||||
first))
|
||||
first)))
|
||||
|
||||
(defmacro backquote-list*-macro (first &rest list)
|
||||
(defalias 'backquote-list*-macro
|
||||
(cons 'macro
|
||||
#'(lambda (first &rest list)
|
||||
"Like `list' but the last argument is the tail of the new list.
|
||||
|
||||
For example (backquote-list* \\='a \\='b \\='c) => (a b . c)"
|
||||
|
|
@ -75,7 +78,7 @@ For example (backquote-list* \\='a \\='b \\='c) => (a b . c)"
|
|||
(setq newlist (list 'cons (car rest) newlist)
|
||||
rest (cdr rest)))
|
||||
newlist)
|
||||
first))
|
||||
first))))
|
||||
|
||||
(defalias 'backquote-list* (symbol-function 'backquote-list*-macro))
|
||||
|
||||
|
|
@ -90,8 +93,10 @@ For example (backquote-list* \\='a \\='b \\='c) => (a b . c)"
|
|||
(defconst backquote-splice-symbol '\,@
|
||||
"Symbol used to represent a splice inside a backquote.")
|
||||
|
||||
(defmacro backquote (structure)
|
||||
"Argument STRUCTURE describes a template to build.
|
||||
(defalias 'backquote
|
||||
(cons 'macro
|
||||
#'(lambda (structure)
|
||||
"Argument STRUCTURE describes a template to build.
|
||||
|
||||
The whole structure acts as if it were quoted except for certain
|
||||
places where expressions are evaluated and inserted or spliced in.
|
||||
|
|
@ -107,7 +112,7 @@ Vectors work just like lists. Nested backquotes are permitted.
|
|||
|
||||
Note that some macros, such as `pcase', use this symbol for other
|
||||
purposes."
|
||||
(cdr (backquote-process structure)))
|
||||
(cdr (backquote-process structure)))))
|
||||
|
||||
;; GNU Emacs has no reader macros
|
||||
|
||||
|
|
@ -118,29 +123,31 @@ purposes."
|
|||
;; constant, 1 => to be unquoted, 2 => to be spliced in.
|
||||
;; The top-level backquote macro just discards the tag.
|
||||
|
||||
(defun backquote-delay-process (s level)
|
||||
(defalias 'backquote-delay-process
|
||||
#'(lambda (s level)
|
||||
"Process a (un|back|splice)quote inside a backquote.
|
||||
This simply recurses through the body."
|
||||
(let ((exp (backquote-listify (list (cons 0 (list 'quote (car s))))
|
||||
(backquote-process (cdr s) level))))
|
||||
(cons (if (eq (car-safe exp) 'quote) 0 1) exp)))
|
||||
(cons (if (eq (car-safe exp) 'quote) 0 1) exp))))
|
||||
|
||||
(defun backquote-process (s &optional level)
|
||||
"Process the body of a backquote.
|
||||
(defalias 'backquote-process
|
||||
#'(lambda (s &optional level)
|
||||
"Process the body of a backquote.
|
||||
S is the body. Returns a cons cell whose cdr is piece of code which
|
||||
is the macro-expansion of S, and whose car is a small integer whose value
|
||||
can either indicate that the code is constant (0), or not (1), or returns
|
||||
a list which should be spliced into its environment (2).
|
||||
LEVEL is only used internally and indicates the nesting level:
|
||||
0 (the default) is for the toplevel nested inside a single backquote."
|
||||
(unless level (setq level 0))
|
||||
(if (null level) (setq level 0))
|
||||
(cond
|
||||
((vectorp s)
|
||||
(let ((n (backquote-process (append s ()) level)))
|
||||
(if (= (car n) 0)
|
||||
(cons 0 s)
|
||||
(cons 1 (cond
|
||||
((not (listp (cdr n)))
|
||||
((null (listp (cdr n)))
|
||||
(list 'vconcat (cdr n)))
|
||||
((eq (nth 1 n) 'list)
|
||||
(cons 'vector (nthcdr 2 n)))
|
||||
|
|
@ -150,7 +157,7 @@ LEVEL is only used internally and indicates the nesting level:
|
|||
(list 'apply '(function vector) (cdr n))))))))
|
||||
((atom s)
|
||||
;; FIXME: Use macroexp-quote!
|
||||
(cons 0 (if (or (null s) (eq s t) (not (symbolp s)))
|
||||
(cons 0 (if (or (null s) (eq s t) (null (symbolp s)))
|
||||
s
|
||||
(list 'quote s))))
|
||||
((eq (car s) backquote-unquote-symbol)
|
||||
|
|
@ -187,8 +194,8 @@ LEVEL is only used internally and indicates the nesting level:
|
|||
;; Stop if the cdr is an expression inside a backquote or
|
||||
;; unquote since this needs to go recursively through
|
||||
;; backquote-process.
|
||||
(not (or (eq (car rest) backquote-unquote-symbol)
|
||||
(eq (car rest) backquote-backquote-symbol))))
|
||||
(null (or (eq (car rest) backquote-unquote-symbol)
|
||||
(eq (car rest) backquote-backquote-symbol))))
|
||||
(setq item (backquote-process (car rest) level))
|
||||
(cond
|
||||
((= (car item) 2)
|
||||
|
|
@ -199,8 +206,8 @@ LEVEL is only used internally and indicates the nesting level:
|
|||
list nil))
|
||||
;; Otherwise, put any preceding nonspliced items into LISTS.
|
||||
(if list
|
||||
(push (backquote-listify list '(0 . nil)) lists))
|
||||
(push (cdr item) lists)
|
||||
(setq lists (cons (backquote-listify list '(0 . nil)) lists)))
|
||||
(setq lists (cons (cdr item) lists))
|
||||
(setq list nil))
|
||||
(t
|
||||
(setq list (cons item list))))
|
||||
|
|
@ -208,8 +215,9 @@ LEVEL is only used internally and indicates the nesting level:
|
|||
;; Handle nonsplicing final elements, and the tail of the list
|
||||
;; (which remains in REST).
|
||||
(if (or rest list)
|
||||
(push (backquote-listify list (backquote-process rest level))
|
||||
lists))
|
||||
(setq lists
|
||||
(cons (backquote-listify list (backquote-process rest level))
|
||||
lists)))
|
||||
;; Turn LISTS into a form that produces the combined list.
|
||||
(setq expression
|
||||
(if (or (cdr lists)
|
||||
|
|
@ -219,13 +227,14 @@ LEVEL is only used internally and indicates the nesting level:
|
|||
;; Tack on any initial elements.
|
||||
(if firstlist
|
||||
(setq expression (backquote-listify firstlist (cons 1 expression))))
|
||||
(cons (if (eq (car-safe expression) 'quote) 0 1) expression)))))
|
||||
(cons (if (eq (car-safe expression) 'quote) 0 1) expression))))))
|
||||
|
||||
;; backquote-listify takes (tag . structure) pairs from backquote-process
|
||||
;; and decides between append, list, backquote-list*, and cons depending
|
||||
;; on which tags are in the list.
|
||||
|
||||
(defun backquote-listify (list old-tail)
|
||||
(defalias 'backquote-listify
|
||||
#'(lambda (list old-tail)
|
||||
(let ((heads nil) (tail (cdr old-tail)) (list-tail list) (item nil))
|
||||
(if (= (car old-tail) 0)
|
||||
(setq tail (eval tail)
|
||||
|
|
@ -248,7 +257,7 @@ LEVEL is only used internally and indicates the nesting level:
|
|||
(cons (if use-list* 'backquote-list* 'cons)
|
||||
(append heads (list tail))))
|
||||
tail))
|
||||
(t (cons 'list heads)))))
|
||||
(t (cons 'list heads))))))
|
||||
|
||||
|
||||
;; Give `,' and `,@' documentation strings which can be examined by C-h f.
|
||||
|
|
|
|||
|
|
@ -908,7 +908,7 @@ function calls currently active."
|
|||
(backtrace-mode)
|
||||
(setq backtrace-view '(:show-flags t)
|
||||
backtrace-frames frames
|
||||
backtrace-print-function #'prin1;; #'cl-prin1 STOUGH, 2024-02-12
|
||||
backtrace-print-function #'cl-prin1
|
||||
)
|
||||
(backtrace-print)
|
||||
(filter-buffer-substring (point-min) (point-max)))))
|
||||
|
|
|
|||
|
|
@ -293,67 +293,9 @@ The original FORM is not changed. Return a changed copy of FORM, or FORM."
|
|||
(if changed new form))
|
||||
form)))
|
||||
|
||||
(defalias 'byte-run--posify-def-form
|
||||
#'(lambda (form)
|
||||
"Posify FORM, a defining form.
|
||||
A defining form is one whose function has a `byte-run-defined-form'
|
||||
property. Examples are `defun', `cl-defmethod'."
|
||||
(let* ((df (get (car form) 'byte-run-defined-form))
|
||||
(mth (car df))
|
||||
(nth (and (integerp mth) (if (> mth 0) mth (- mth))))
|
||||
(posifier (cdr df))
|
||||
defining-symbol ; Bound for `byte-run-posify-doc-string'.
|
||||
old-ds new-ds new-obj
|
||||
(obj
|
||||
(and nth
|
||||
(condition-case nil
|
||||
(nth nth form)
|
||||
(wrong-type-argument nil)
|
||||
(t nil)))))
|
||||
(if obj
|
||||
(progn
|
||||
(setq new-obj
|
||||
(if (> mth 0)
|
||||
(if (symbol-with-pos-p obj)
|
||||
(progn (setq defining-symbol obj)
|
||||
(bare-symbol obj))
|
||||
obj)
|
||||
(if (and (eq (car-safe obj) 'quote)
|
||||
(symbol-with-pos-p (car-safe (cdr obj))))
|
||||
(progn (setq defining-symbol (car (cdr obj)))
|
||||
(list 'quote (bare-symbol (car (cdr obj)))))
|
||||
obj)))
|
||||
(if (let (symbols-with-pos-enabled)
|
||||
(null (eq new-obj obj)))
|
||||
(progn
|
||||
(if (functionp posifier)
|
||||
(progn
|
||||
(setq posifier (funcall posifier form))))
|
||||
(let ((flat-posifier
|
||||
(if (integerp posifier)
|
||||
posifier
|
||||
;; At this stage the &rest arguments won't have been
|
||||
;; gathered into a single list, hence we must treat
|
||||
;; them as individual arguments.
|
||||
(+ (car posifier) (cdr posifier)))))
|
||||
(setq old-ds (nth flat-posifier form))
|
||||
(setq new-ds
|
||||
(byte-run-posify-doc-string (and (stringp old-ds) old-ds)))
|
||||
(append (take nth form)
|
||||
(list new-obj)
|
||||
(take (- flat-posifier (1+ nth))
|
||||
(nthcdr (1+ nth) form))
|
||||
(list new-ds)
|
||||
(nthcdr (if (stringp old-ds)
|
||||
(1+ flat-posifier)
|
||||
flat-posifier)
|
||||
form))))
|
||||
form))
|
||||
form))))
|
||||
|
||||
(defalias 'byte-run--posify-list
|
||||
#'(lambda (form)
|
||||
"Posify any lambda or defining forms still unposified in the list FORM.
|
||||
"Posify any lambda forms still unposified in the list FORM.
|
||||
This original FORM is not changed. Return a changed copy of FORM or FORM."
|
||||
(let ((a form)
|
||||
changed elt new)
|
||||
|
|
@ -367,7 +309,7 @@ This original FORM is not changed. Return a changed copy of FORM or FORM."
|
|||
(eq (bare-symbol (car a)) 'lambda))
|
||||
(if (and
|
||||
(cdr-safe a)
|
||||
(listp (car-safe (cdr a)))) ; valid param list.
|
||||
(consp (car-safe (cdr a)))) ; valid param list.
|
||||
(let ((stripped
|
||||
(byte-run-posify-lambda-form
|
||||
a (symbol-with-pos-pos (car a))
|
||||
|
|
@ -377,21 +319,14 @@ This original FORM is not changed. Return a changed copy of FORM or FORM."
|
|||
a (cdr a))
|
||||
(setq new (cons (car a) new) ; param list.
|
||||
a (cdr a))
|
||||
(setq new (cons (car a) new) ; doc string.
|
||||
a (cdr a))
|
||||
;; Leave the doc string as the car of A to be accumulated
|
||||
;; into NEW below.
|
||||
;; (setq new (cons (car a) new) ; doc string.
|
||||
;; a (cdr a))
|
||||
(setq changed t))
|
||||
(byte-run-pull-lambda-source (car a))
|
||||
(setq new (cons 'lambda new)
|
||||
a (cdr a))))
|
||||
|
||||
;; Do we need to posify a defining form?
|
||||
(if (and (symbolp (car a))
|
||||
(get (car a) 'byte-run-defined-form))
|
||||
(let ((stripped (byte-run--posify-def-form a)))
|
||||
(if (null (eq stripped a))
|
||||
(progn
|
||||
(setq a stripped)
|
||||
(setq changed t)))))
|
||||
(byte-run-pull-lambda-source (car a))
|
||||
(setq a (cons 'lambda (cdr a))
|
||||
changed t)))
|
||||
|
||||
;; Accumulate an element.
|
||||
(if (consp a)
|
||||
|
|
@ -431,14 +366,13 @@ This original FORM is not changed. Return a changed copy of FORM or FORM."
|
|||
rev)
|
||||
form))))
|
||||
|
||||
(defalias 'byte-run-posify-all-lambdas-etc
|
||||
(defalias 'byte-run-posify-all-lambdas
|
||||
#'(lambda (form)
|
||||
"Posify any lambda forms still unposified in FORM.
|
||||
Also strip the positions of any `lambda' which doesn't open a form.
|
||||
|
||||
FORM is any Lisp object, but is usually a list or a vector or a
|
||||
record, containing symbols with position. Return FORM, possibly
|
||||
destructively modified."
|
||||
FORM is any Lisp object, but is usually a list or a vector or a record,
|
||||
containing symbols with position. Return a modified copy of FORM, or
|
||||
FORM."
|
||||
(setq byte-run--ssp-seen (make-hash-table :test 'eq))
|
||||
(cond
|
||||
((consp form)
|
||||
|
|
@ -682,47 +616,52 @@ read-stream (typically as a symbol) where FORM occurred or nil.
|
|||
|
||||
The modification of FORM will be done by creating a new list
|
||||
form."
|
||||
(let* ((bare-ds (bare-symbol defining-symbol))
|
||||
(cand-doc-string (nth 2 form))
|
||||
(doc-string
|
||||
(and (byte-run-valid-doc-string cand-doc-string)
|
||||
cand-doc-string))
|
||||
(already-posified
|
||||
(and doc-string
|
||||
(cond
|
||||
((stringp doc-string)
|
||||
(string-match "^;POS\036\001\001\001" doc-string))
|
||||
((stringp (car-safe (cdr-safe doc-string)))
|
||||
(string-match "^;POS\036\001\001\001"
|
||||
(car (cdr doc-string))))
|
||||
;; We need a proper list with at least the arglist present.
|
||||
(if (and (proper-list-p form)
|
||||
(cdr-safe form))
|
||||
(let* ((bare-ds (bare-symbol defining-symbol))
|
||||
(cand-doc-string (nth 2 form))
|
||||
(doc-string
|
||||
(and (byte-run-valid-doc-string cand-doc-string)
|
||||
cand-doc-string))
|
||||
(already-posified
|
||||
(and doc-string
|
||||
(cond
|
||||
((stringp doc-string)
|
||||
(string-match "^;POS\036\001\001\001" doc-string))
|
||||
((stringp (car-safe (cdr-safe doc-string)))
|
||||
(string-match "^;POS\036\001\001\001"
|
||||
(car (cdr doc-string))))
|
||||
;;;; STOUGH TO AMEND WHEN APPROPRIATE, 2023-12-17
|
||||
(t t) ; For (:documentation 'symbol), in oclosures.
|
||||
(t t) ; For (:documentation 'symbol), in oclosures.
|
||||
;;;; END OF STOUGH
|
||||
)))
|
||||
(empty-body-allowed
|
||||
(and bare-ds (get bare-ds 'empty-body-allowed)))
|
||||
(insert (or (null doc-string)
|
||||
(and (null empty-body-allowed)
|
||||
(null (nthcdr 3 form))))))
|
||||
)))
|
||||
(empty-body-allowed
|
||||
(and bare-ds (get bare-ds 'empty-body-allowed)))
|
||||
(insert (or (null doc-string)
|
||||
(and (null empty-body-allowed)
|
||||
(null (nthcdr 3 form))))))
|
||||
|
||||
(cond
|
||||
((and (null already-posified)
|
||||
(>= (length form) 2))
|
||||
(let ((new-doc-string (byte-run-posify-doc-string
|
||||
doc-string
|
||||
position
|
||||
lambda-read-stream)))
|
||||
(append
|
||||
(if byte-compile-in-progress
|
||||
(take 1 form)
|
||||
(list 'lambda)) ; Strip the lambda of its position.
|
||||
(take 1 (cdr form))
|
||||
(list new-doc-string)
|
||||
(nthcdr (if insert 2 3) form))))
|
||||
((and (null byte-compile-in-progress)
|
||||
(symbol-with-pos-p (car form)))
|
||||
(cons 'lambda (cdr form)))
|
||||
(t form)))))
|
||||
(cond
|
||||
((and (null already-posified)
|
||||
(>= (length form) 2))
|
||||
(let ((new-doc-string (byte-run-posify-doc-string
|
||||
doc-string
|
||||
position
|
||||
lambda-read-stream)))
|
||||
(append
|
||||
(if byte-compile-in-progress
|
||||
(take 1 form)
|
||||
(list 'lambda)) ; Strip the lambda of its position.
|
||||
(take 1 (cdr form))
|
||||
(list new-doc-string)
|
||||
(nthcdr (if insert 2 3) form))))
|
||||
((and (null byte-compile-in-progress)
|
||||
(symbol-with-pos-p (car form)))
|
||||
(cons 'lambda (cdr form)))
|
||||
(t form)))
|
||||
;; We've got an invalid lambda form. Just return it.
|
||||
form)))
|
||||
|
||||
(defalias 'function-put
|
||||
;; We don't want people to just use `put' because we can't conveniently
|
||||
|
|
@ -740,39 +679,32 @@ So far, FUNCTION can only be a symbol, not a lambda expression."
|
|||
;; handle declarations in macro definitions and this is the first file
|
||||
;; loaded by loadup.el that uses declarations in macros. We specify
|
||||
;; the values as named aliases so that `describe-variable' prints
|
||||
;; something useful; cf. Bug#40491. We can only use backquotes inside
|
||||
;; the lambdas and not for those properties that are used by functions
|
||||
;; loaded before backquote.el.
|
||||
;; something useful; cf. Bug#40491. Backquotes can be used freely in
|
||||
;; this file since 2024-06.
|
||||
|
||||
(defalias 'byte-run--set-advertised-calling-convention
|
||||
#'(lambda (f _args arglist when)
|
||||
(list 'set-advertised-calling-convention
|
||||
(list 'quote f) (list 'quote arglist) (list 'quote when))))
|
||||
`(set-advertised-calling-convention ',f ',arglist ',when)))
|
||||
|
||||
(defalias 'byte-run--set-obsolete
|
||||
#'(lambda (f _args new-name when)
|
||||
(list 'make-obsolete
|
||||
(list 'quote f) (list 'quote new-name) when)))
|
||||
`(make-obsolete ',f ',new-name ,when)))
|
||||
|
||||
(defalias 'byte-run--set-interactive-only
|
||||
#'(lambda (f _args instead)
|
||||
(list 'function-put (list 'quote f)
|
||||
''interactive-only (list 'quote instead))))
|
||||
`(function-put ',f 'interactive-only ',instead)))
|
||||
|
||||
(defalias 'byte-run--set-pure
|
||||
#'(lambda (f _args val)
|
||||
(list 'function-put (list 'quote f)
|
||||
''pure (list 'quote val))))
|
||||
`(function-put ',f 'pure ',val)))
|
||||
|
||||
(defalias 'byte-run--set-side-effect-free
|
||||
#'(lambda (f _args val)
|
||||
(list 'function-put (list 'quote f)
|
||||
''side-effect-free (list 'quote val))))
|
||||
`(function-put ',f 'side-effect-free ',val)))
|
||||
|
||||
(defalias 'byte-run--set-important-return-value
|
||||
#'(lambda (f _args val)
|
||||
(list 'function-put (list 'quote f)
|
||||
''important-return-value (list 'quote val))))
|
||||
`(function-put ',f 'important-return-value ',val)))
|
||||
|
||||
(put 'compiler-macro 'edebug-declaration-spec
|
||||
'(&or symbolp ("lambda" &define lambda-list lambda-doc def-body)))
|
||||
|
|
@ -801,51 +733,39 @@ So far, FUNCTION can only be a symbol, not a lambda expression."
|
|||
|
||||
(defalias 'byte-run--set-doc-string
|
||||
#'(lambda (f _args pos)
|
||||
(list 'function-put (list 'quote f)
|
||||
''doc-string-elt (if (numberp pos)
|
||||
pos
|
||||
(list 'quote pos)))))
|
||||
`(function-put ',f 'doc-string-elt
|
||||
,(if (numberp pos) pos `',pos))))
|
||||
|
||||
(defalias 'byte-run--set-indent
|
||||
#'(lambda (f _args val)
|
||||
(list 'function-put (list 'quote f)
|
||||
''lisp-indent-function (if (numberp val)
|
||||
val
|
||||
(list 'quote val)))))
|
||||
`(function-put ',f 'lisp-indent-function
|
||||
,(if (numberp val) val `',val))))
|
||||
|
||||
(defalias 'byte-run--set-speed
|
||||
#'(lambda (f _args val)
|
||||
(list 'function-put (list 'quote f)
|
||||
''speed (list 'quote val))))
|
||||
`(function-put ',f 'speed ',val)))
|
||||
|
||||
(defalias 'byte-run--set-safety
|
||||
#'(lambda (f _args val)
|
||||
(list 'function-put (list 'quote f)
|
||||
''safety (list 'quote val))))
|
||||
`(function-put ',f 'safety ',val)))
|
||||
|
||||
(defalias 'byte-run--set-completion
|
||||
#'(lambda (f _args val)
|
||||
(list 'function-put (list 'quote f)
|
||||
''completion-predicate (list 'function val))))
|
||||
`(function-put ',f 'completion-predicate #',val)))
|
||||
|
||||
(defalias 'byte-run--set-modes
|
||||
#'(lambda (f _args &rest val)
|
||||
(list 'function-put (list 'quote f)
|
||||
''command-modes (list 'quote val))))
|
||||
`(function-put ',f 'command-modes ',val)))
|
||||
|
||||
(defalias 'byte-run--set-interactive-args
|
||||
#'(lambda (f args &rest val)
|
||||
(setq args (remove '&optional (remove '&rest args)))
|
||||
(list 'function-put (list 'quote f)
|
||||
''interactive-args
|
||||
(list
|
||||
'quote
|
||||
(mapcar
|
||||
(lambda (elem)
|
||||
(cons
|
||||
(seq-position args (car elem))
|
||||
(cadr elem)))
|
||||
val)))))
|
||||
`(function-put ',f 'interactive-args
|
||||
',(mapcar (lambda (elem)
|
||||
(cons
|
||||
(seq-position args (car elem))
|
||||
(cadr elem)))
|
||||
val))))
|
||||
|
||||
(defalias 'byte-run--extract-sym-from-form
|
||||
#'(lambda (form args)
|
||||
|
|
@ -961,93 +881,70 @@ an example of its use."
|
|||
f def-index))
|
||||
|
||||
(cons
|
||||
(list 'function-put (list 'quote f)
|
||||
''byte-run-defined-form
|
||||
(list 'quote (cons def-index (if doc-n
|
||||
(cons doc-index doc-n)
|
||||
doc-index))))
|
||||
(list
|
||||
'progn
|
||||
(list 'or 'defining-symbol
|
||||
(list 'setq 'defining-symbol def-spec))
|
||||
|
||||
(list 'let*
|
||||
(list
|
||||
(list 'old-ds
|
||||
(list 'and (list 'byte-run-valid-doc-string doc-spec)
|
||||
doc-spec))
|
||||
(list 'new-ds (list 'byte-run-posify-doc-string 'old-ds)))
|
||||
;; Strip the symbol position from the name being defined.
|
||||
(list 'if '(null byte-compile-in-progress)
|
||||
(list 'setq def-arg-sym
|
||||
(list 'byte-run-strip-symbol-positions
|
||||
def-arg-sym)))
|
||||
;; Strip the symbol position from the name in the
|
||||
;; original form.
|
||||
(list 'if (list 'and 'cur-evalled-macro-form
|
||||
(list 'null 'byte-compile-in-progress))
|
||||
(list
|
||||
'let
|
||||
(list
|
||||
(list 'stripped-arg
|
||||
(list 'byte-run-strip-symbol-positions
|
||||
(list 'nth def-index
|
||||
'cur-evalled-macro-form))))
|
||||
(list 'setcar (list 'nthcdr def-index
|
||||
'cur-evalled-macro-form)
|
||||
'stripped-arg)))
|
||||
(if empty-body-flag
|
||||
(list 'put def-spec ''empty-body-allowed t)
|
||||
(list 'progn))
|
||||
;; Replace the old doc string with the new, or
|
||||
;; insert the new.
|
||||
(cond
|
||||
(can-insert-doc-before-rest
|
||||
(list 'if (list 'byte-run-valid-doc-string 'old-ds)
|
||||
(list 'setq doc-spec 'new-ds)
|
||||
;; If `doc-spec' isn't a string, it's part of the body.
|
||||
(list 'setq body-spec
|
||||
(list 'cons doc-spec body-spec))
|
||||
(list 'setq doc-spec 'new-ds)))
|
||||
((symbolp doc-spec)
|
||||
(list 'setq doc-spec 'new-ds))
|
||||
(t
|
||||
(list
|
||||
'setq doc-arg-sym
|
||||
(list
|
||||
'append
|
||||
(list 'take doc-n doc-arg-sym)
|
||||
(list
|
||||
'cond
|
||||
;; doc-string present and a non-nil (cdr body):
|
||||
(list (list 'and (list 'byte-run-valid-doc-string
|
||||
doc-spec)
|
||||
after-doc-spec)
|
||||
(list 'list 'new-ds))
|
||||
;; Single string, both doc string and return value:
|
||||
(list (list 'byte-run-valid-doc-string doc-spec)
|
||||
(if empty-body-flag
|
||||
(list 'list 'new-ds)
|
||||
(list 'list 'new-ds 'old-ds)))
|
||||
;; Neither doc string nor return value:
|
||||
(list (list 'null (list 'nthcdr doc-n doc-arg-sym))
|
||||
(if empty-body-flag
|
||||
(list 'list 'new-ds)
|
||||
(list 'list 'new-ds ''nil)))
|
||||
;; No doc string, but a non-nil body, not a string.
|
||||
(list t
|
||||
(list 'list 'new-ds doc-spec)))
|
||||
after-doc-spec))))))))))
|
||||
|
||||
`(function-put ',f 'byte-run-defined-form
|
||||
'(,def-index ,@(if doc-n (cons doc-index doc-n)
|
||||
doc-index)))
|
||||
`(progn
|
||||
(or defining-symbol (setq defining-symbol ,def-spec))
|
||||
(let* ((old-ds (and (byte-run-valid-doc-string ,doc-spec)
|
||||
,doc-spec))
|
||||
(new-ds (byte-run-posify-doc-string old-ds)))
|
||||
;; Strip the symbol position from the name being defined.
|
||||
(if (null byte-compile-in-progress)
|
||||
(setq ,def-arg-sym
|
||||
(byte-run-strip-symbol-positions ,def-arg-sym)))
|
||||
;; Strip the symbol position from the name in the
|
||||
;; original form.
|
||||
(if (and cur-evalled-macro-form
|
||||
(null byte-compile-in-progress))
|
||||
(let ((stripped-arg
|
||||
(byte-run-strip-symbol-positions
|
||||
(nth ,def-index cur-evalled-macro-form))))
|
||||
(setcar (nthcdr ,def-index cur-evalled-macro-form)
|
||||
stripped-arg)))
|
||||
,@(if empty-body-flag
|
||||
`((put ,def-spec 'empty-body-allowed t)))
|
||||
;; Replace the old doc string with the new, or
|
||||
;; insert the new.
|
||||
,(cond
|
||||
(can-insert-doc-before-rest
|
||||
`(if (byte-run-valid-doc-string old-ds)
|
||||
(setq ,doc-spec new-ds)
|
||||
;; if `doc-spec' isn't a string, it's part of the body.
|
||||
(setq ,body-spec (cons ,doc-spec ,body-spec))
|
||||
(setq ,doc-spec new-ds)))
|
||||
((symbolp doc-spec)
|
||||
`(setq ,doc-spec new-ds))
|
||||
(t `(setq ,doc-arg-sym
|
||||
(append
|
||||
(take ,doc-n ,doc-arg-sym)
|
||||
(cond
|
||||
;; doc-string present and a non-nil (cdr body):
|
||||
((and (byte-run-valid-doc-string ,doc-spec)
|
||||
,after-doc-spec)
|
||||
(list new-ds))
|
||||
;; Single string, both doc string and return value
|
||||
((byte-run-valid-doc-string ,doc-spec)
|
||||
,(if empty-body-flag
|
||||
`(list new-ds)
|
||||
`(list new-ds old-ds)))
|
||||
;; Neither doc string nor return value:
|
||||
((null (nthcdr ,doc-n ,doc-arg-sym))
|
||||
,(if empty-body-flag
|
||||
`(list new-ds)
|
||||
`(list new-ds 'nil)))
|
||||
;; No doc string, but a non-nil, non-string body.
|
||||
(t (list new-ds ,doc-spec)))
|
||||
,after-doc-spec))))))))))
|
||||
(put 'byte-run--posify-defining-form 'byte-run-pre-form t)
|
||||
|
||||
(defalias 'byte-run--set-function-type
|
||||
#'(lambda (f _args val &optional f2)
|
||||
(when (and f2 (not (eq f2 f)))
|
||||
(error
|
||||
"`%s' does not match top level function `%s' inside function type \
|
||||
declaration" f2 f))
|
||||
(list 'function-put (list 'quote f)
|
||||
''function-type (list 'quote val))))
|
||||
`(function-put ',f 'function-type ',val)))
|
||||
|
||||
;; Add any new entries to info node `(elisp)Declare Form'.
|
||||
(defvar defun-declarations-alist
|
||||
|
|
@ -1085,14 +982,12 @@ This is used by `declare'.")
|
|||
|
||||
(defalias 'byte-run--set-debug
|
||||
#'(lambda (name _args spec)
|
||||
(list 'progn :autoload-end
|
||||
(list 'put (list 'quote name)
|
||||
''edebug-form-spec (list 'quote spec)))))
|
||||
`(progn :autoload-end
|
||||
(put ',name 'edebug-form-spec ',spec))))
|
||||
|
||||
(defalias 'byte-run--set-no-font-lock-keyword
|
||||
#'(lambda (name _args val)
|
||||
(list 'function-put (list 'quote name)
|
||||
''no-font-lock-keyword (list 'quote val))))
|
||||
`(function-put ',name 'no-font-lock-keyword ',val)))
|
||||
|
||||
(defalias 'byte-run--parse-body
|
||||
#'(lambda (body allow-interactive)
|
||||
|
|
@ -1251,10 +1146,8 @@ interpreted according to `macro-declarations-alist'.
|
|||
(setq body (cons docstring body)))
|
||||
(if (null body)
|
||||
(setq body '(nil)))
|
||||
(let* ((fun (list 'function (cons 'lambda (cons arglist body))))
|
||||
(def (list 'defalias
|
||||
(list 'quote name)
|
||||
(list 'cons ''macro fun))))
|
||||
(let* ((fun `(function (lambda ,arglist ,@body)))
|
||||
(def `(defalias ',name (cons 'macro ,fun))))
|
||||
(if declarations
|
||||
(cons 'prog1 (cons def (car declarations)))
|
||||
def))))))
|
||||
|
|
@ -1279,8 +1172,7 @@ INTERACTIVE is an optional `interactive' specification.
|
|||
(null (delq t (mapcar #'symbolp arglist)))))
|
||||
(error "Malformed arglist: %s" arglist))
|
||||
(let* ((parse (byte-run--parse-body body t))
|
||||
(docstring
|
||||
(nth 0 parse))
|
||||
(docstring (nth 0 parse))
|
||||
(declare-form (nth 1 parse))
|
||||
(interactive-form (nth 2 parse))
|
||||
(body
|
||||
|
|
@ -1299,11 +1191,7 @@ INTERACTIVE is an optional `interactive' specification.
|
|||
(setq body (cons docstring body)))
|
||||
(if (null body)
|
||||
(setq body '(nil)))
|
||||
(let ((def (list 'defalias
|
||||
(list 'quote name)
|
||||
(list 'function
|
||||
(cons 'lambda
|
||||
(cons arglist body))))))
|
||||
(let ((def `(defalias ',name (function (lambda ,arglist ,@body)))))
|
||||
(if declarations
|
||||
(cons 'prog1 (cons def (car declarations)))
|
||||
def))))
|
||||
|
|
@ -1649,7 +1537,7 @@ obsolete, for example a date or a release number."
|
|||
"Like `progn', but the body always runs interpreted (not compiled).
|
||||
If you think you need this, you're probably making a mistake somewhere."
|
||||
(declare (debug t) (indent 0) (obsolete nil "24.4"))
|
||||
(list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body)))))
|
||||
`(eval ',(if (cdr body) `(progn ,@body) (car body))))
|
||||
|
||||
|
||||
;; interface to evaluating things at compile time and/or load time
|
||||
|
|
@ -1665,8 +1553,7 @@ constant. In interpreted code, this is entirely equivalent to
|
|||
not necessarily) computed at load time if eager macro expansion
|
||||
is enabled."
|
||||
(declare (debug (&rest def-form)) (indent 0))
|
||||
(list 'quote (eval (cons 'progn (byte-run-posify-all-lambdas-etc body))
|
||||
lexical-binding)))
|
||||
`',(eval `(progn ,@(byte-run-posify-all-lambdas body)) lexical-binding))
|
||||
|
||||
(defmacro eval-and-compile (&rest body)
|
||||
"Like `progn', but evaluates the body at compile time and at load time.
|
||||
|
|
@ -1678,8 +1565,7 @@ enabled."
|
|||
;; When the byte-compiler expands code, this macro is not used, so we're
|
||||
;; either about to run `body' (plain interpretation) or we're doing eager
|
||||
;; macroexpansion.
|
||||
(list 'quote (eval (cons 'progn (byte-run-posify-all-lambdas-etc body))
|
||||
lexical-binding)))
|
||||
`',(eval `(progn ,@(byte-run-posify-all-lambdas body)) lexical-binding))
|
||||
|
||||
(defun with-no-warnings (&rest body)
|
||||
"Like `progn', but prevents compiler warnings in the body."
|
||||
|
|
|
|||
|
|
@ -632,7 +632,7 @@ See `byte-run--posify-def-form' in byte-run.el."
|
|||
(cl-generic--method-qualifier-p (car ptr)))
|
||||
(setq ptr (cdr ptr))
|
||||
(setq i (1+ i)))
|
||||
`(1 . (3 . ,i))))))
|
||||
`(3 . ,i)))))
|
||||
|
||||
(defun cl--generic-member-method (specializers qualifiers methods)
|
||||
(while
|
||||
|
|
|
|||
|
|
@ -384,8 +384,8 @@ Assumes the caller has bound `macroexpand-all-environment'."
|
|||
|
||||
;; `eval-when-compile' and `eval-and-compile' need their args expanded
|
||||
;; first, in case there are any backquote constructs in them which
|
||||
;; would otherwise confuse the `byte-run-posify-all-lambdas-etc' calls
|
||||
;; in those macros.
|
||||
;; would otherwise confuse the `byte-run-posify-all-lambdas' calls in
|
||||
;; those macros.
|
||||
(macroexpand (macroexp--all-forms form 1)
|
||||
macroexpand-all-environment))
|
||||
|
||||
|
|
@ -473,8 +473,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
|
|||
|
||||
(`(function . ,_) form)
|
||||
(`(quote ,_arg)
|
||||
(if (null byte-compile-in-progress)
|
||||
(setq form (byte-run-posify-all-lambdas-etc form)))
|
||||
(setq form (byte-run-posify-all-lambdas form))
|
||||
form)
|
||||
(`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body)
|
||||
pcase--dontcare))
|
||||
|
|
|
|||
|
|
@ -129,6 +129,7 @@
|
|||
(defvar real-defvar (symbol-function 'defvar))
|
||||
(fset 'defvar (symbol-function 'defvar-bootstrap))
|
||||
(load "emacs-lisp/debug-early")
|
||||
(load "emacs-lisp/backquote")
|
||||
(load "emacs-lisp/byte-run")
|
||||
(byte-run-posify-existing-defaliases)
|
||||
(byte-run-posify-existing-lambdas)
|
||||
|
|
@ -136,7 +137,6 @@
|
|||
;; (makunbound 'early-lambda-lists)
|
||||
(setq early-lambda-lists nil) ; We don't want its symbols with
|
||||
; position in the dumped image.
|
||||
(load "emacs-lisp/backquote")
|
||||
(load "subr")
|
||||
(load "keymap")
|
||||
|
||||
|
|
@ -180,11 +180,11 @@
|
|||
;;;; END OF NEW STOUGH
|
||||
|
||||
(load "emacs-lisp/debug-early")
|
||||
(load "emacs-lisp/backquote")
|
||||
(load "emacs-lisp/byte-run")
|
||||
(message "loadup.el, just after second load of byte-run.el.")
|
||||
(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")
|
||||
;; Second loading of these files to clear out symbols with positions from
|
||||
;; lambda symbols. This absolutely requires macroexp.el.
|
||||
;; In the second loading, we make `internal-macroexpand-for-load' unbound so
|
||||
|
|
|
|||
|
|
@ -225,12 +225,14 @@
|
|||
(ert-deftest backtrace-tests--single-and-multi-line ()
|
||||
"Forms in backtrace frames can be on a single line or on multiple lines."
|
||||
(ert-with-test-buffer (:name "single-multi-line")
|
||||
(let* ((arg '(lambda (x) ; Quote this so it isn't made into a closure.
|
||||
;; Make the form long enough so `number' should not
|
||||
;; appear on the first line once pretty-printed.
|
||||
(interactive (region-beginning))
|
||||
(let ((number (1+ x)))
|
||||
(+ x number))))
|
||||
(let* ((arg
|
||||
(byte-run-strip-lambda-doc
|
||||
'(lambda (x) ; Quote this so it isn't made into a closure.
|
||||
;; Make the form long enough so `number' should not
|
||||
;; appear on the first line once pretty-printed.
|
||||
(interactive (region-beginning))
|
||||
(let ((number (1+ x)))
|
||||
(+ x number)))))
|
||||
(header-string "Test header: ")
|
||||
(header (format "%s%s\n" header-string arg))
|
||||
(insert-header-function (lambda ()
|
||||
|
|
|
|||
|
|
@ -179,8 +179,9 @@
|
|||
(cconv-closure-convert
|
||||
'#'(lambda (x) (let ((f #'(lambda () (+ x 1))))
|
||||
(funcall f)))))
|
||||
(byte-run-strip-lambda-doc
|
||||
'#'(lambda (x) (let ((f #'(lambda (x) (+ x 1))))
|
||||
(funcall f x)))))
|
||||
(funcall f x))))))
|
||||
|
||||
;; Bug#30872.
|
||||
(should
|
||||
|
|
@ -216,10 +217,11 @@
|
|||
(cconv-closure-convert
|
||||
'#'(lambda (x)
|
||||
#'(lambda () x)))))
|
||||
'#'(lambda (x)
|
||||
(internal-make-closure
|
||||
nil (x) nil
|
||||
(internal-get-closed-var 0)))))
|
||||
(byte-run-strip-lambda-doc
|
||||
'#'(lambda (x)
|
||||
(internal-make-closure
|
||||
nil (x) nil
|
||||
(internal-get-closed-var 0))))))
|
||||
|
||||
;; Basic case:
|
||||
(should (equal (byte-run-strip-lambda-doc (cconv-tests--intern-all
|
||||
|
|
@ -228,22 +230,24 @@
|
|||
(let ((f #'(lambda () x)))
|
||||
(let ((x 'b))
|
||||
(list x (funcall f))))))))
|
||||
'#'(lambda (x)
|
||||
(let ((f #'(lambda (x) x)))
|
||||
(let ((x 'b)
|
||||
(closed-x x))
|
||||
(list x (funcall f closed-x)))))))
|
||||
(byte-run-strip-lambda-doc
|
||||
'#'(lambda (x)
|
||||
(let ((f #'(lambda (x) x)))
|
||||
(let ((x 'b)
|
||||
(closed-x x))
|
||||
(list x (funcall f closed-x))))))))
|
||||
(should (equal (byte-run-strip-lambda-doc (cconv-tests--intern-all
|
||||
(cconv-closure-convert
|
||||
'#'(lambda (x)
|
||||
(let ((f #'(lambda () x)))
|
||||
(let* ((x 'b))
|
||||
(list x (funcall f))))))))
|
||||
'#'(lambda (x)
|
||||
(let ((f #'(lambda (x) x)))
|
||||
(let* ((closed-x x)
|
||||
(x 'b))
|
||||
(list x (funcall f closed-x)))))))
|
||||
(byte-run-strip-lambda-doc
|
||||
'#'(lambda (x)
|
||||
(let ((f #'(lambda (x) x)))
|
||||
(let* ((closed-x x)
|
||||
(x 'b))
|
||||
(list x (funcall f closed-x))))))))
|
||||
|
||||
;; With the lambda-lifted shadowed variable also being captured:
|
||||
(should (equal (byte-run-strip-lambda-doc
|
||||
|
|
@ -254,13 +258,14 @@
|
|||
(let ((f #'(lambda () x)))
|
||||
(let ((x 'a))
|
||||
(list x (funcall f)))))))))
|
||||
'#'(lambda (x)
|
||||
(internal-make-closure
|
||||
nil (x) nil
|
||||
(let ((f #'(lambda (x) x)))
|
||||
(let ((x 'a)
|
||||
(closed-x (internal-get-closed-var 0)))
|
||||
(list x (funcall f closed-x))))))))
|
||||
(byte-run-strip-lambda-doc
|
||||
'#'(lambda (x)
|
||||
(internal-make-closure
|
||||
nil (x) nil
|
||||
(let ((f #'(lambda (x) x)))
|
||||
(let ((x 'a)
|
||||
(closed-x (internal-get-closed-var 0)))
|
||||
(list x (funcall f closed-x)))))))))
|
||||
(should (equal (byte-run-strip-lambda-doc
|
||||
(cconv-tests--intern-all
|
||||
(cconv-closure-convert
|
||||
|
|
@ -269,13 +274,14 @@
|
|||
(let ((f #'(lambda () x)))
|
||||
(let* ((x 'a))
|
||||
(list x (funcall f)))))))))
|
||||
'#'(lambda (x)
|
||||
(internal-make-closure
|
||||
nil (x) nil
|
||||
(let ((f #'(lambda (x) x)))
|
||||
(let* ((closed-x (internal-get-closed-var 0))
|
||||
(x 'a))
|
||||
(list x (funcall f closed-x))))))))
|
||||
(byte-run-strip-lambda-doc
|
||||
'#'(lambda (x)
|
||||
(internal-make-closure
|
||||
nil (x) nil
|
||||
(let ((f #'(lambda (x) x)))
|
||||
(let* ((closed-x (internal-get-closed-var 0))
|
||||
(x 'a))
|
||||
(list x (funcall f closed-x)))))))))
|
||||
;; With lambda-lifted shadowed variable also being mutably captured:
|
||||
(should (equal (byte-run-strip-lambda-doc
|
||||
(cconv-tests--intern-all
|
||||
|
|
@ -286,16 +292,17 @@
|
|||
(setq x x)
|
||||
(let ((x 'a))
|
||||
(list x (funcall f)))))))))
|
||||
'#'(lambda (x)
|
||||
(let ((x (list x)))
|
||||
(internal-make-closure
|
||||
nil (x) nil
|
||||
(let ((f #'(lambda (x) (car-safe x))))
|
||||
(setcar (internal-get-closed-var 0)
|
||||
(car-safe (internal-get-closed-var 0)))
|
||||
(let ((x 'a)
|
||||
(closed-x (internal-get-closed-var 0)))
|
||||
(list x (funcall f closed-x)))))))))
|
||||
(byte-run-strip-lambda-doc
|
||||
'#'(lambda (x)
|
||||
(let ((x (list x)))
|
||||
(internal-make-closure
|
||||
nil (x) nil
|
||||
(let ((f #'(lambda (x) (car-safe x))))
|
||||
(setcar (internal-get-closed-var 0)
|
||||
(car-safe (internal-get-closed-var 0)))
|
||||
(let ((x 'a)
|
||||
(closed-x (internal-get-closed-var 0)))
|
||||
(list x (funcall f closed-x))))))))))
|
||||
(should (equal (byte-run-strip-lambda-doc
|
||||
(cconv-tests--intern-all
|
||||
(cconv-closure-convert
|
||||
|
|
@ -305,16 +312,17 @@
|
|||
(setq x x)
|
||||
(let* ((x 'a))
|
||||
(list x (funcall f)))))))))
|
||||
'#'(lambda (x)
|
||||
(let ((x (list x)))
|
||||
(internal-make-closure
|
||||
nil (x) nil
|
||||
(let ((f #'(lambda (x) (car-safe x))))
|
||||
(setcar (internal-get-closed-var 0)
|
||||
(car-safe (internal-get-closed-var 0)))
|
||||
(let* ((closed-x (internal-get-closed-var 0))
|
||||
(x 'a))
|
||||
(list x (funcall f closed-x)))))))))
|
||||
(byte-run-strip-lambda-doc
|
||||
'#'(lambda (x)
|
||||
(let ((x (list x)))
|
||||
(internal-make-closure
|
||||
nil (x) nil
|
||||
(let ((f #'(lambda (x) (car-safe x))))
|
||||
(setcar (internal-get-closed-var 0)
|
||||
(car-safe (internal-get-closed-var 0)))
|
||||
(let* ((closed-x (internal-get-closed-var 0))
|
||||
(x 'a))
|
||||
(list x (funcall f closed-x))))))))))
|
||||
;; Lambda-lifted variable that isn't actually captured where it is shadowed:
|
||||
(should (equal (byte-run-strip-lambda-doc
|
||||
(cconv-tests--intern-all
|
||||
|
|
@ -324,13 +332,14 @@
|
|||
(h #'(lambda () (setq x x))))
|
||||
(let ((x 'b))
|
||||
(list x (funcall g) (funcall h))))))))
|
||||
'#'(lambda (x)
|
||||
(let ((x (list x)))
|
||||
(let ((g #'(lambda (x) (car-safe x)))
|
||||
(h #'(lambda (x) (setcar x (car-safe x)))))
|
||||
(let ((x 'b)
|
||||
(closed-x x))
|
||||
(list x (funcall g closed-x) (funcall h closed-x))))))))
|
||||
(byte-run-strip-lambda-doc
|
||||
'#'(lambda (x)
|
||||
(let ((x (list x)))
|
||||
(let ((g #'(lambda (x) (car-safe x)))
|
||||
(h #'(lambda (x) (setcar x (car-safe x)))))
|
||||
(let ((x 'b)
|
||||
(closed-x x))
|
||||
(list x (funcall g closed-x) (funcall h closed-x)))))))))
|
||||
(should (equal (byte-run-strip-lambda-doc
|
||||
(cconv-tests--intern-all
|
||||
(cconv-closure-convert
|
||||
|
|
@ -339,14 +348,14 @@
|
|||
(h #'(lambda () (setq x x))))
|
||||
(let* ((x 'b))
|
||||
(list x (funcall g) (funcall h))))))))
|
||||
'#'(lambda (x)
|
||||
(let ((x (list x)))
|
||||
(let ((g #'(lambda (x) (car-safe x)))
|
||||
(h #'(lambda (x) (setcar x (car-safe x)))))
|
||||
(let* ((closed-x x)
|
||||
(x 'b))
|
||||
(list x (funcall g closed-x) (funcall h closed-x))))))))
|
||||
)
|
||||
(byte-run-strip-lambda-doc
|
||||
'#'(lambda (x)
|
||||
(let ((x (list x)))
|
||||
(let ((g #'(lambda (x) (car-safe x)))
|
||||
(h #'(lambda (x) (setcar x (car-safe x)))))
|
||||
(let* ((closed-x x)
|
||||
(x 'b))
|
||||
(list x (funcall g closed-x) (funcall h closed-x))))))))))
|
||||
|
||||
(ert-deftest cconv-tests-interactive-closure-bug51695 ()
|
||||
(let ((f (let ((d 51695))
|
||||
|
|
@ -384,10 +393,11 @@
|
|||
(prefix-numeric-value current-prefix-arg)
|
||||
'toggle)))
|
||||
(ignore arg))))
|
||||
(if (cadr (nth 2 (cadr f))))
|
||||
(f2 (byte-run-strip-lambda-doc f))
|
||||
(if (cadr (nth 2 (cadr f2))))
|
||||
(if2))
|
||||
(cconv-closure-convert f)
|
||||
(setq if2 (cadr (nth 2 (cadr f))))
|
||||
(cconv-closure-convert f2)
|
||||
(setq if2 (cadr (nth 2 (cadr f2))))
|
||||
(should (eq if if2))))
|
||||
|
||||
(provide 'cconv-tests)
|
||||
|
|
|
|||
|
|
@ -169,11 +169,12 @@
|
|||
(byte-run-strip-lambda-doc
|
||||
(macroexpand-1
|
||||
'(erc--with-dependent-type-match (repeat face) erc-match)))
|
||||
'(backquote-list*
|
||||
'repeat :match (lambda (w v)
|
||||
(require 'erc-match)
|
||||
(widget-editable-list-match w v))
|
||||
'(face)))))
|
||||
(byte-run-strip-lambda-doc
|
||||
'(backquote-list*
|
||||
'repeat :match (lambda (w v)
|
||||
(require 'erc-match)
|
||||
(widget-editable-list-match w v))
|
||||
'(face))))))
|
||||
|
||||
(ert-deftest erc--doarray ()
|
||||
(let ((array "abcdefg")
|
||||
|
|
|
|||
Loading…
Reference in a new issue