[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/interpreted-function 03b4c13a897: interpreted-function
From: |
Stefan Monnier |
Subject: |
scratch/interpreted-function 03b4c13a897: interpreted-function |
Date: |
Sun, 24 Mar 2024 12:29:13 -0400 (EDT) |
branch: scratch/interpreted-function
commit 03b4c13a897a055139b52114738288f4b3c8d99d
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
interpreted-function
---
lisp/emacs-lisp/byte-opt.el | 5 +-
lisp/emacs-lisp/bytecomp.el | 20 +++--
lisp/emacs-lisp/cconv.el | 38 +++++----
lisp/emacs-lisp/cl-preloaded.el | 4 +-
lisp/emacs-lisp/cl-print.el | 31 ++++++++
lisp/emacs-lisp/comp-common.el | 2 +
lisp/emacs-lisp/disass.el | 6 +-
lisp/emacs-lisp/lisp-mode.el | 1 -
lisp/emacs-lisp/nadvice.el | 6 +-
lisp/emacs-lisp/oclosure.el | 96 ++++++++++-------------
lisp/emacs-lisp/pcase.el | 18 ++++-
lisp/help.el | 3 +-
lisp/profiler.el | 5 +-
lisp/simple.el | 5 +-
src/alloc.c | 23 +++---
src/callint.c | 6 +-
src/data.c | 31 +++++++-
src/eval.c | 112 ++++++++++++++++++++-------
src/lread.c | 35 +++++----
src/profiler.c | 4 -
test/lisp/erc/resources/erc-d/erc-d-tests.el | 5 +-
test/lisp/help-fns-tests.el | 4 +-
22 files changed, 296 insertions(+), 164 deletions(-)
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index f6df40a2d9b..e461a2b4ffd 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -164,7 +164,7 @@ Earlier variables shadow later ones with the same name.")
;; The byte-code will be really inlined in byte-compile-unfold-bcf.
(byte-compile--check-arity-bytecode form fn)
`(,fn ,@(cdr form)))
- ((or `(lambda . ,_) `(closure . ,_))
+ ((pred interpreted-function-p)
;; While byte-compile-unfold-bcf can inline dynbind byte-code into
;; letbind byte-code (or any other combination for that matter), we
;; can only inline dynbind source into dynbind source or lexbind
@@ -482,7 +482,7 @@ There can be multiple entries for the same NAME if it has
several aliases.")
(push name byte-optimize--dynamic-vars)
`(,fn ,name . ,optimized-rest)))
- (`(,(pred byte-code-function-p) . ,exps)
+ (`(,(pred closurep) . ,exps) ;FIXME: Is this case of nay use?
(cons fn (mapcar #'byte-optimize-form exps)))
((guard (when for-effect
@@ -1873,6 +1873,7 @@ See Info node `(elisp) Integer Basics'."
charsetp
;; data.c
arrayp atom bare-symbol-p bool-vector-p bufferp byte-code-function-p
+ interpreted-function-p closurep
byteorder car-safe cdr-safe char-or-string-p char-table-p
condition-variable-p consp eq floatp indirect-function
integer-or-marker-p integerp keywordp listp markerp
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 7af568cfe34..c016a49d33e 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -2897,9 +2897,14 @@ otherwise, print without quoting."
(defun byte-compile--reify-function (fun)
"Return an expression which will evaluate to a function value FUN.
FUN should be an interpreted closure."
- (pcase-let* ((`(closure ,env ,args . ,body) fun)
- (`(,preamble . ,body) (macroexp-parse-body body))
- (renv ()))
+ (let* ((args (aref fun 0))
+ (body (aref fun 1))
+ (env (aref fun 2))
+ (docstring (function-documentation fun))
+ (iform (interactive-form fun))
+ (preamble `(,@(if docstring (list docstring))
+ ,@(if iform (list iform))))
+ (renv ()))
;; Turn the function's closed vars (if any) into local let bindings.
(dolist (binding env)
(cond
@@ -2936,11 +2941,11 @@ If FORM is a lambda or a macro, byte-compile it as a
function."
(if (symbolp form) form "provided"))
fun)
(t
- (when (or (symbolp form) (eq (car-safe fun) 'closure))
+ (when (or (symbolp form) (interpreted-function-p fun))
;; `fun' is a function *value*, so try to recover its
;; corresponding source code.
- (when (setq lexical-binding (eq (car-safe fun) 'closure))
- (setq fun (byte-compile--reify-function fun)))
+ (setq lexical-binding (not (null (aref fun 2))))
+ (setq fun (byte-compile--reify-function fun))
(setq need-a-value t))
;; Expand macros.
(setq fun (byte-compile-preprocess fun))
@@ -5107,7 +5112,6 @@ binding slots have been popped."
;; `arglist' is the list of arguments (or t if not recognized).
;; `body' is the body of `lam' (or t if not recognized).
((or `(lambda ,arglist . ,body)
- ;; `(closure ,_ ,arglist . ,body)
(and `(internal-make-closure ,arglist . ,_) (let body t))
(and (let arglist t) (let body t)))
lam))
@@ -5545,7 +5549,7 @@ invoked interactively."
" <compiled macro>"
" <macro>"))
((eq 'lambda (car f))
- "<function>")
+ "<function-like list>")
(t "???"))
(format " (%d callers + %d calls = %d)"
;; Does the optimizer eliminate common subexpressions?-sk
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 4ff47971351..e6a78f07762 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -902,7 +902,7 @@ lexically and dynamically bound symbols actually used by
FORM."
(delete-dups cconv--dynbindings)))))
(cons fvs dyns)))))
-(defun cconv-make-interpreted-closure (fun env)
+(defun cconv-make-interpreted-closure (args body env docstring iform)
"Make a closure for the interpreter.
This is intended to be called at runtime by the ELisp interpreter (when
the code has not been compiled).
@@ -911,22 +911,27 @@ ENV is the runtime representation of the lexical
environment,
i.e. a list whose elements can be either plain symbols (which indicate
that this symbol should use dynamic scoping) or pairs (SYMBOL . VALUE)
for the lexical bindings."
- (cl-assert (eq (car-safe fun) 'lambda))
+ (cl-assert (consp body))
+ (cl-assert (listp args))
(let ((lexvars (delq nil (mapcar #'car-safe env))))
- (if (or (null lexvars)
- ;; Functions with a `:closure-dont-trim-context' marker
- ;; should keep their whole context untrimmed (bug#59213).
- (and (eq :closure-dont-trim-context (nth 2 fun))
- ;; Check the function doesn't just return the magic keyword.
- (nthcdr 3 fun)))
+ (if (or
+ ;; Functions with a `:closure-dont-trim-context' marker
+ ;; should keep their whole context untrimmed (bug#59213).
+ (and (eq :closure-dont-trim-context (car body))
+ ;; Check the function doesn't just return the magic keyword.
+ (cdr body)
+ ;; Drop the magic marker from the closure.
+ (setq body (cdr body)))
+ ;; There's no var to capture, so skip the analysis.
+ (null lexvars))
;; The lexical environment is empty, or needs to be preserved,
;; so there's no need to look for free variables.
- ;; Attempting to replace ,(cdr fun) by a macroexpanded version
- ;; causes bootstrap to fail.
- `(closure ,env . ,(cdr fun))
+ ;; Attempting to replace body by a macroexpanded version
+ ;; caused bootstrap to fail.
+ (make-interpreted-closure args body env docstring iform)
;; We could try and cache the result of the macroexpansion and
;; `cconv-fv' analysis. Not sure it's worth the trouble.
- (let* ((form `#',fun)
+ (let* ((form `#'(lambda ,args ,iform . ,body))
(expanded-form
(let ((lexical-binding t) ;; Tell macros which dialect is in use.
;; Make the macro aware of any defvar declarations in scope.
@@ -935,10 +940,10 @@ for the lexical bindings."
(append env macroexp--dynvars) env)))
(macroexpand-all form macroexpand-all-environment)))
;; Since we macroexpanded the body, we may as well use that.
- (expanded-fun-cdr
+ (expanded-fun-body
(pcase expanded-form
- (`#'(lambda . ,cdr) cdr)
- (_ (cdr fun))))
+ (`#'(lambda ,_args ,_iform . ,newbody) newbody)
+ (_ body)))
(dynvars (delq nil (mapcar (lambda (b) (if (symbolp b) b)) env)))
(fvs (cconv-fv expanded-form lexvars dynvars))
@@ -946,7 +951,8 @@ for the lexical bindings."
(cdr fvs))))
;; Never return a nil env, since nil means to use the dynbind
;; dialect of ELisp.
- `(closure ,(or newenv '(t)) . ,expanded-fun-cdr)))))
+ (make-interpreted-closure args expanded-fun-body (or newenv '(t))
+ docstring iform)))))
(provide 'cconv)
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 35a8d79a1cd..98d89fbc259 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -434,7 +434,9 @@ For this build of Emacs it's %dbit."
"Abstract supertype of function values.")
(cl--define-built-in-type compiled-function (function)
"Abstract type of functions that have been compiled.")
-(cl--define-built-in-type byte-code-function (compiled-function)
+(cl--define-built-in-type closure (function)
+ "Abstract type of functions represented by a vector-like object.")
+(cl--define-built-in-type byte-code-function (compiled-function closure)
"Type of functions that have been byte-compiled.")
(cl--define-built-in-type subr (atom)
"Abstract type of functions compiled to machine code.")
diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 5e5eee1da9e..440a439a9a7 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -237,6 +237,37 @@ into a button whose action shows the function's
disassembly.")
'byte-code-function object)))))
(princ ")" stream)))
+(cl-defmethod cl-print-object ((object interpreted-function) stream)
+ (unless stream (setq stream standard-output))
+ (princ "#f(lambda " stream)
+ (let ((args (help-function-arglist object 'preserve-names)))
+ (if args
+ (prin1 args stream)
+ (princ "()" stream)))
+ (let ((env (aref object 2)))
+ (if (null env)
+ (princ " :dynbind" stream)
+ (princ " " stream)
+ (cl-print-object
+ (vconcat (mapcar (lambda (x) (if (consp x) (list (car x) (cdr x)) x))
+ env))
+ stream)))
+ (let* ((doc+usage (documentation object 'raw))
+ ;; Drop args which `help-function-arglist' already printed.
+ (doc.usage (help-split-fundoc doc+usage object))
+ (doc (if doc.usage (cdr doc.usage) doc+usage)))
+ (when doc
+ (princ " " stream)
+ (prin1 doc stream)))
+ (let ((inter (interactive-form object)))
+ (when inter
+ (princ " " stream)
+ (cl-print-object inter stream)))
+ (dolist (exp (aref object 1))
+ (princ " " stream)
+ (cl-print-object exp stream))
+ (princ ")" stream))
+
;; This belongs in oclosure.el, of course, but some load-ordering issues make
it
;; complicated.
(cl-defmethod cl-print-object ((object accessor) stream)
diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el
index 4edfe811586..62fd28f772e 100644
--- a/lisp/emacs-lisp/comp-common.el
+++ b/lisp/emacs-lisp/comp-common.el
@@ -118,7 +118,9 @@ Used to modify the compiler environment."
(buffer-substring
(function ((or integer marker) (or integer marker)) string))
(bufferp (function (t) boolean))
+ (closurep (function (t) boolean))
(byte-code-function-p (function (t) boolean))
+ (interpreted-function-p (function (t) boolean))
(capitalize (function ((or integer string)) (or integer string)))
(car (function (list) t))
(car-less-than-car (function (list list) boolean))
diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el
index 850cc2085f7..15caee9b29c 100644
--- a/lisp/emacs-lisp/disass.el
+++ b/lisp/emacs-lisp/disass.el
@@ -129,7 +129,7 @@ redefine OBJECT if it is a symbol."
(setq args (help-function-arglist obj)) ;save arg list
(setq obj (cdr obj)) ;throw lambda away
(setq obj (cdr obj)))
- ((byte-code-function-p obj)
+ ((closurep obj)
(setq args (help-function-arglist obj)))
(t (error "Compilation failed")))
(if (zerop indent) ; not a nested function
@@ -178,7 +178,9 @@ redefine OBJECT if it is a symbol."
(t
(insert "Uncompiled body: ")
(let ((print-escape-newlines t))
- (prin1 (macroexp-progn obj)
+ (prin1 (macroexp-progn (if (interpreted-function-p obj)
+ (aref obj 1)
+ obj))
(current-buffer))))))
(if interactive-p
(message "")))
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 3475d944337..601cc7bf712 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -1347,7 +1347,6 @@ Lisp function does not specify a special indentation."
(put 'condition-case 'lisp-indent-function 2)
(put 'handler-case 'lisp-indent-function 1) ;CL
(put 'unwind-protect 'lisp-indent-function 1)
-(put 'closure 'lisp-indent-function 2)
(defun indent-sexp (&optional endpos)
"Indent each line of the list starting just after point.
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index 5326c520601..36df143a82a 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -185,7 +185,7 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are
expected.")
(defun advice--interactive-form-1 (function)
"Like `interactive-form' but preserves the static context if needed."
(let ((if (interactive-form function)))
- (if (or (null if) (not (eq 'closure (car-safe function))))
+ (if (not (and if (interpreted-function-p function)))
if
(cl-assert (eq 'interactive (car if)))
(let ((form (cadr if)))
@@ -193,14 +193,14 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are
expected.")
if
;; The interactive is expected to be run in the static context
;; that the function captured.
- (let ((ctx (nth 1 function)))
+ (let ((ctx (aref function 2)))
`(interactive
,(let* ((f (if (eq 'function (car-safe form)) (cadr form) form)))
;; If the form jut returns a function, preserve the fact that
;; it just returns a function, which is an info we use in
;; `advice--make-interactive-form'.
(if (eq 'lambda (car-safe f))
- `',(eval form ctx)
+ (eval form ctx)
`(eval ',form ',ctx))))))))))
(defun advice--interactive-form (function)
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 4da8e61aaa7..165d7c4b6e8 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -146,7 +146,7 @@
(setf (cl--find-class 'oclosure)
(oclosure--class-make 'oclosure
"The root parent of all OClosure types"
- nil (list (cl--find-class 'function))
+ nil (list (cl--find-class 'closure))
'(oclosure)))
(defun oclosure--p (oclosure)
(not (not (oclosure-type oclosure))))
@@ -431,75 +431,57 @@ ARGS and BODY are the same as for `lambda'."
(defun oclosure--fix-type (_ignore oclosure)
"Helper function to implement `oclosure-lambda' via a macro.
-This has 2 uses:
-- For interpreted code, this converts the representation of type information
- by moving it from the docstring to the environment.
-- For compiled code, this is used as a marker which cconv uses to check that
- immutable fields are indeed not mutated."
- (if (byte-code-function-p oclosure)
- ;; Actually, this should never happen since `cconv.el' should have
- ;; optimized away the call to this function.
- oclosure
- ;; For byte-coded functions, we store the type as a symbol in the docstring
- ;; slot. For interpreted functions, there's no specific docstring slot
- ;; so `Ffunction' turns the symbol into a string.
- ;; We thus have convert it back into a symbol (via `intern') and then
- ;; stuff it into the environment part of the closure with a special
- ;; marker so we can distinguish this entry from actual variables.
- (cl-assert (eq 'closure (car-safe oclosure)))
- (let ((typename (nth 3 oclosure))) ;; The "docstring".
- (cl-assert (stringp typename))
- (push (cons :type (intern typename))
- (cadr oclosure))
- oclosure)))
+This is used as a marker which cconv uses to check that
+immutable fields are indeed not mutated."
+ (cl-assert (closurep oclosure))
+ ;; This should happen only for interpreted closures since `cconv.el'
+ ;; should have optimized away the call to this function.
+ oclosure)
(defun oclosure--copy (oclosure mutlist &rest args)
+ (cl-assert (closurep oclosure))
(if (byte-code-function-p oclosure)
(apply #'make-closure oclosure
(if (null mutlist)
args
(mapcar (lambda (arg) (if (pop mutlist) (list arg) arg)) args)))
- (cl-assert (eq 'closure (car-safe oclosure))
- nil "oclosure not closure: %S" oclosure)
- (cl-assert (eq :type (caar (cadr oclosure))))
- (let ((env (cadr oclosure)))
- `(closure
- (,(car env)
- ,@(named-let loop ((env (cdr env)) (args args))
- (when args
- (cons (cons (caar env) (car args))
- (loop (cdr env) (cdr args)))))
- ,@(nthcdr (1+ (length args)) env))
- ,@(nthcdr 2 oclosure)))))
+ (cl-assert (consp (aref oclosure 1)))
+ (cl-assert (null (aref oclosure 3)))
+ (cl-assert (symbolp (aref oclosure 4)))
+ (let ((env (aref oclosure 2)))
+ (make-interpreted-closure
+ (aref oclosure 0)
+ (aref oclosure 1)
+ (named-let loop ((env env) (args args))
+ (if (null args) env
+ (cons (cons (caar env) (car args))
+ (loop (cdr env) (cdr args)))))
+ (aref oclosure 4)
+ (if (> (length oclosure) 5)
+ `(interactive ,(aref oclosure 5)))))))
(defun oclosure--get (oclosure index mutable)
- (if (byte-code-function-p oclosure)
- (let* ((csts (aref oclosure 2))
- (v (aref csts index)))
- (if mutable (car v) v))
- (cl-assert (eq 'closure (car-safe oclosure)))
- (cl-assert (eq :type (caar (cadr oclosure))))
- (cdr (nth (1+ index) (cadr oclosure)))))
+ (cl-assert (closurep oclosure))
+ (let* ((csts (aref oclosure 2)))
+ (if (vectorp csts)
+ (let ((v (aref csts index)))
+ (if mutable (car v) v))
+ (cdr (nth index csts)))))
(defun oclosure--set (v oclosure index)
- (if (byte-code-function-p oclosure)
- (let* ((csts (aref oclosure 2))
- (cell (aref csts index)))
- (setcar cell v))
- (cl-assert (eq 'closure (car-safe oclosure)))
- (cl-assert (eq :type (caar (cadr oclosure))))
- (setcdr (nth (1+ index) (cadr oclosure)) v)))
+ (cl-assert (closurep oclosure))
+ (let ((csts (aref oclosure 2)))
+ (if (vectorp csts)
+ (let ((cell (aref csts index)))
+ (setcar cell v))
+ (setcdr (nth index csts) v))))
(defun oclosure-type (oclosure)
- "Return the type of OCLOSURE, or nil if the arg is not a OClosure."
- (if (byte-code-function-p oclosure)
- (let ((type (and (> (length oclosure) 4) (aref oclosure 4))))
- (if (symbolp type) type))
- (and (eq 'closure (car-safe oclosure))
- (let* ((env (car-safe (cdr oclosure)))
- (first-var (car-safe env)))
- (and (eq :type (car-safe first-var))
- (cdr first-var))))))
+ "Return the type of OCLOSURE, or nil if the arg is not an OClosure."
+ (and (closurep oclosure)
+ (> (length oclosure) 4)
+ (let ((type (aref oclosure 4)))
+ (if (symbolp type) type))))
(defconst oclosure--accessor-prototype
;; Use `oclosure--lambda' to circumvent a bootstrapping problem:
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 40d917795e3..96dcd958fb0 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -630,7 +630,9 @@ recording whether the var has been referenced by earlier
parts of the match."
(symbolp . arrayp)
(symbolp . vectorp)
(symbolp . stringp)
+ (symbolp . closurep)
(symbolp . byte-code-function-p)
+ (symbolp . interpreted-function-p)
(symbolp . compiled-function-p)
(symbolp . recordp)
(null . integerp)
@@ -640,7 +642,9 @@ recording whether the var has been referenced by earlier
parts of the match."
(null . arrayp)
(null . vectorp)
(null . stringp)
+ (null . closurep)
(null . byte-code-function-p)
+ (null . interpreted-function-p)
(null . compiled-function-p)
(null . recordp)
(integerp . consp)
@@ -654,25 +658,37 @@ recording whether the var has been referenced by earlier
parts of the match."
(numberp . arrayp)
(numberp . vectorp)
(numberp . stringp)
+ (numberp . closurep)
(numberp . byte-code-function-p)
+ (numberp . interpreted-function-p)
(numberp . compiled-function-p)
(numberp . recordp)
(consp . arrayp)
(consp . atom)
(consp . vectorp)
(consp . stringp)
+ (consp . closurep)
(consp . byte-code-function-p)
+ (consp . interpreted-function-p)
(consp . compiled-function-p)
(consp . recordp)
+ (arrayp . closurep)
(arrayp . byte-code-function-p)
+ (arrayp . interpreted-function-p)
(arrayp . compiled-function-p)
+ (vectorp . closurep)
(vectorp . byte-code-function-p)
+ (vectorp . interpreted-function-p)
(vectorp . compiled-function-p)
(vectorp . recordp)
(stringp . vectorp)
(stringp . recordp)
+ (stringp . closurep)
(stringp . byte-code-function-p)
- (stringp . compiled-function-p)))
+ (stringp . interpreted-function-p)
+ (stringp . compiled-function-p)
+ (interpreted-function-p . byte-code-function-p)
+ (interpreted-function-p . compiled-function-p)))
(defun pcase--mutually-exclusive-p (pred1 pred2)
(or (member (cons pred1 pred2)
diff --git a/lisp/help.el b/lisp/help.el
index bafe6032942..c0e06bc8932 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -2343,9 +2343,8 @@ the same names as used in the original source code, when
possible."
;; If definition is a macro, find the function inside it.
(if (eq (car-safe def) 'macro) (setq def (cdr def)))
(cond
- ((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0))
+ ((and (closurep def) (listp (aref def 0))) (aref def 0))
((eq (car-safe def) 'lambda) (nth 1 def))
- ((eq (car-safe def) 'closure) (nth 2 def))
((and (featurep 'native-compile)
(subrp def)
(listp (subr-native-lambda-list def)))
diff --git a/lisp/profiler.el b/lisp/profiler.el
index 4e02cd1d890..eb72f128c07 100644
--- a/lisp/profiler.el
+++ b/lisp/profiler.el
@@ -275,10 +275,7 @@ Optional argument MODE means only check for the specified
mode (cpu or mem)."
(define-hash-table-test 'profiler-function-equal #'function-equal
- (lambda (f) (cond
- ((byte-code-function-p f) (aref f 1))
- ((eq (car-safe f) 'closure) (cddr f))
- (t f))))
+ (lambda (f) (if (closurep f) (aref f 1) f)))
(defun profiler-calltree-build-unified (tree log)
;; Let's try to unify all those partial backtraces into a single
diff --git a/lisp/simple.el b/lisp/simple.el
index 0645f18cc78..01d7d95aaee 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2703,15 +2703,14 @@ function as needed."
(or (stringp doc)
(fixnump doc) (fixnump (cdr-safe doc))))))
(pcase function
- ((pred byte-code-function-p)
+ ((pred closurep)
(when (> (length function) 4)
(let ((doc (aref function 4)))
(when (funcall docstring-p doc) doc))))
((or (pred stringp) (pred vectorp)) "Keyboard macro.")
(`(keymap . ,_)
"Prefix command (definition is a keymap associating keystrokes with
commands).")
- ((or `(lambda ,_args . ,body) `(closure ,_env ,_args . ,body)
- `(autoload ,_file . ,body))
+ ((or `(lambda ,_args . ,body) `(autoload ,_file . ,body))
(let ((doc (car body)))
(when (funcall docstring-p doc)
doc)))
diff --git a/src/alloc.c b/src/alloc.c
index 2ffd2415447..b48f7549a7e 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3813,17 +3813,22 @@ stack before executing the byte-code.
usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING
INTERACTIVE-SPEC &rest ELEMENTS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- if (! ((FIXNUMP (args[COMPILED_ARGLIST])
- || CONSP (args[COMPILED_ARGLIST])
- || NILP (args[COMPILED_ARGLIST]))
- && STRINGP (args[COMPILED_BYTECODE])
- && !STRING_MULTIBYTE (args[COMPILED_BYTECODE])
- && VECTORP (args[COMPILED_CONSTANTS])
- && FIXNATP (args[COMPILED_STACK_DEPTH])))
+ if (CONSP (args[COMPILED_BYTECODE]))
+ ; /* An interpreted closure. */
+ else if ((FIXNUMP (args[COMPILED_ARGLIST])
+ || CONSP (args[COMPILED_ARGLIST])
+ || NILP (args[COMPILED_ARGLIST]))
+ && STRINGP (args[COMPILED_BYTECODE])
+ && !STRING_MULTIBYTE (args[COMPILED_BYTECODE])
+ && VECTORP (args[COMPILED_CONSTANTS])
+ && FIXNATP (args[COMPILED_STACK_DEPTH]))
+ {
+ /* Bytecode must be immovable. */
+ pin_string (args[COMPILED_BYTECODE]);
+ }
+ else
error ("Invalid byte-code object");
- /* Bytecode must be immovable. */
- pin_string (args[COMPILED_BYTECODE]);
/* We used to purecopy everything here, if purify-flag was set. This worked
OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
diff --git a/src/callint.c b/src/callint.c
index b31faba8704..787bb2858d4 100644
--- a/src/callint.c
+++ b/src/callint.c
@@ -319,10 +319,10 @@ invoke it (via an `interactive' spec that contains, for
instance, an
{
Lisp_Object funval = Findirect_function (function, Qt);
uintmax_t events = num_input_events;
+ Lisp_Object env = COMPILEDP (funval) && CONSP (AREF (funval, 1))
+ ? AREF (funval, 2) : Qnil;
/* Compute the arg values using the user's expression. */
- specs = Feval (specs,
- CONSP (funval) && EQ (Qclosure, XCAR (funval))
- ? CAR_SAFE (XCDR (funval)) : Qnil);
+ specs = Feval (specs, env);
if (events != num_input_events || !NILP (record_flag))
{
/* We should record this command on the command history.
diff --git a/src/data.c b/src/data.c
index 69b990bed76..31788abf468 100644
--- a/src/data.c
+++ b/src/data.c
@@ -249,7 +249,9 @@ a fixed set of types. */)
return XSUBR (object)->max_args == UNEVALLED ? Qspecial_form
: SUBR_NATIVE_COMPILEDP (object) ? Qsubr_native_elisp
: Qprimitive_function;
- case PVEC_COMPILED: return Qcompiled_function;
+ case PVEC_COMPILED:
+ return CONSP (AREF (object, 1))
+ ? Qinterpreted_function : Qbyte_code_function;
case PVEC_BUFFER: return Qbuffer;
case PVEC_CHAR_TABLE: return Qchar_table;
case PVEC_BOOL_VECTOR: return Qbool_vector;
@@ -519,12 +521,32 @@ DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
return Qnil;
}
+DEFUN ("closurep", Fclosurep, Sclosurep,
+ 1, 1, 0,
+ doc: /* Return t if OBJECT is a function object. */)
+ (Lisp_Object object)
+{
+ if (COMPILEDP (object))
+ return Qt;
+ return Qnil;
+}
+
DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
1, 1, 0,
doc: /* Return t if OBJECT is a byte-compiled function object. */)
(Lisp_Object object)
{
- if (COMPILEDP (object))
+ if (COMPILEDP (object) && STRINGP (AREF (object, 1)))
+ return Qt;
+ return Qnil;
+}
+
+DEFUN ("interpreted-function-p", Finterpreted_function_p,
+ Sinterpreted_function_p, 1, 1, 0,
+ doc: /* Return t if OBJECT is an interpreted function value. */)
+ (Lisp_Object object)
+{
+ if (COMPILEDP (object) && CONSP (AREF (object, 1)))
return Qt;
return Qnil;
}
@@ -4247,7 +4269,8 @@ syms_of_data (void)
DEFSYM (Qspecial_form, "special-form");
DEFSYM (Qprimitive_function, "primitive-function");
DEFSYM (Qsubr_native_elisp, "subr-native-elisp");
- DEFSYM (Qcompiled_function, "compiled-function");
+ DEFSYM (Qbyte_code_function, "byte-code-function");
+ DEFSYM (Qinterpreted_function, "interpreted-function");
DEFSYM (Qbuffer, "buffer");
DEFSYM (Qframe, "frame");
DEFSYM (Qvector, "vector");
@@ -4312,6 +4335,8 @@ syms_of_data (void)
defsubr (&Smarkerp);
defsubr (&Ssubrp);
defsubr (&Sbyte_code_function_p);
+ defsubr (&Sinterpreted_function_p);
+ defsubr (&Sclosurep);
defsubr (&Smodule_function_p);
defsubr (&Schar_or_string_p);
defsubr (&Sthreadp);
diff --git a/src/eval.c b/src/eval.c
index f48d7b0682f..382ef2d1843 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -510,6 +510,32 @@ usage: (quote ARG) */)
return XCAR (args);
}
+DEFUN ("make-interpreted-closure", Fmake_interpreted_closure,
+ Smake_interpreted_closure, 3, 5, 0,
+ doc: /* Make an interpreted closure.
+ARGS should be the list of formal arguments.
+BODY should be a non-empty list of forms.
+ENV should be a lexical environment, like the second argument of `eval'.
+IFORM if non-nil should be of the form (interactive ...). */)
+ (Lisp_Object args, Lisp_Object body, Lisp_Object env,
+ Lisp_Object docstring, Lisp_Object iform)
+{
+ CHECK_CONS (body); /* Make sure it's not confused with byte-code! */
+ if (!NILP (iform))
+ {
+ iform = Fcdr (iform);
+ return CALLN (Fmake_byte_code,
+ args, body, env, Qnil, docstring,
+ NILP (Fcdr (iform))
+ ? Fcar (iform)
+ : CALLN (Fvector, XCAR (iform), XCDR (iform)));
+ }
+ else if (!NILP (docstring))
+ return CALLN (Fmake_byte_code, args, body, env, Qnil, docstring);
+ else
+ return CALLN (Fmake_byte_code, args, body, env);
+}
+
DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
doc: /* Like `quote', but preferred for objects which are functions.
In byte compilation, `function' causes its argument to be handled by
@@ -525,33 +551,55 @@ usage: (function ARG) */)
if (!NILP (XCDR (args)))
xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args));
- if (!NILP (Vinternal_interpreter_environment)
- && CONSP (quoted)
+ if (CONSP (quoted)
&& EQ (XCAR (quoted), Qlambda))
{ /* This is a lambda expression within a lexical environment;
return an interpreted closure instead of a simple lambda. */
Lisp_Object cdr = XCDR (quoted);
- Lisp_Object tmp = cdr;
- if (CONSP (tmp)
- && (tmp = XCDR (tmp), CONSP (tmp))
- && (tmp = XCAR (tmp), CONSP (tmp))
- && (EQ (QCdocumentation, XCAR (tmp))))
- { /* Handle the special (:documentation <form>) to build the docstring
+ Lisp_Object args = Fcar (cdr);
+ cdr = Fcdr (cdr);
+ Lisp_Object docstring = Qnil, iform = Qnil;
+ if (CONSP (cdr))
+ {
+ docstring = XCAR (cdr);
+ if (STRINGP (docstring))
+ {
+ Lisp_Object tmp = XCDR (cdr);
+ if (!NILP (tmp))
+ cdr = tmp;
+ else /* It's not a docstring, it's a return value. */
+ docstring = Qnil;
+ }
+ /* Handle the special (:documentation <form>) to build the docstring
dynamically. */
- Lisp_Object docstring = eval_sub (Fcar (XCDR (tmp)));
- if (SYMBOLP (docstring) && !NILP (docstring))
- /* Hack for OClosures: Allow the docstring to be a symbol
- * (the OClosure's type). */
- docstring = Fsymbol_name (docstring);
- CHECK_STRING (docstring);
- cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr))));
- }
- if (NILP (Vinternal_make_interpreted_closure_function))
- return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment,
cdr));
+ else if (CONSP (docstring)
+ && EQ (QCdocumentation, XCAR (docstring))
+ && (docstring = eval_sub (Fcar (XCDR (docstring))),
+ true))
+ cdr = XCDR (cdr);
+ else
+ docstring = Qnil; /* Not a docstring after all. */
+ }
+ if (CONSP (cdr))
+ {
+ iform = XCAR (cdr);
+ if (CONSP (iform)
+ && EQ (Qinteractive, XCAR (iform)))
+ cdr = XCDR (cdr);
+ else
+ iform = Qnil; /* Not an interactive-form after all. */
+ }
+ if (NILP (cdr))
+ cdr = Fcons (Qnil, Qnil); /* Make sure the body is never empty! */
+
+ if (NILP (Vinternal_interpreter_environment)
+ || NILP (Vinternal_make_interpreted_closure_function))
+ return Fmake_interpreted_closure
+ (args, cdr, Vinternal_interpreter_environment, docstring, iform);
else
- return call2 (Vinternal_make_interpreted_closure_function,
- Fcons (Qlambda, cdr),
- Vinternal_interpreter_environment);
+ return call5 (Vinternal_make_interpreted_closure_function,
+ args, cdr, Vinternal_interpreter_environment,
+ docstring, iform);
}
else
/* Simply quote the argument. */
@@ -2949,7 +2997,7 @@ FUNCTIONP (Lisp_Object object)
else if (CONSP (object))
{
Lisp_Object car = XCAR (object);
- return EQ (car, Qlambda) || EQ (car, Qclosure);
+ return EQ (car, Qlambda);
}
else
return false;
@@ -3192,10 +3240,12 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
engine directly. */
if (FIXNUMP (syms_left))
return exec_byte_code (fun, XFIXNUM (syms_left), nargs, arg_vector);
- /* Otherwise the bytecode object uses dynamic binding and the
- ARGLIST slot contains a standard formal argument list whose
- variables are bound dynamically below. */
- lexenv = Qnil;
+ /* Otherwise the closure either is interpreted
+ or uses dynamic binding and the ARGLIST slot contains a standard
+ formal argument list whose variables are bound dynamically below. */
+ lexenv = CONSP (AREF (fun, COMPILED_BYTECODE))
+ ? AREF (fun, COMPILED_CONSTANTS)
+ : Qnil;
}
#ifdef HAVE_MODULES
else if (MODULE_FUNCTIONP (fun))
@@ -3279,7 +3329,14 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
val = XSUBR (fun)->function.a0 ();
}
else
- val = exec_byte_code (fun, 0, 0, NULL);
+ {
+ eassert (COMPILEDP (fun));
+ val = CONSP (AREF (fun, COMPILED_BYTECODE))
+ /* Interpreted function. */
+ ? Fprogn (AREF (fun, COMPILED_BYTECODE))
+ /* Dynbound bytecode. */
+ : exec_byte_code (fun, 0, 0, NULL);
+ }
return unbind_to (count, val);
}
@@ -4424,6 +4481,7 @@ alist of active lexical bindings. */);
defsubr (&Ssetq);
defsubr (&Squote);
defsubr (&Sfunction);
+ defsubr (&Smake_interpreted_closure);
defsubr (&Sdefault_toplevel_value);
defsubr (&Sset_default_toplevel_value);
defsubr (&Sdefvar);
diff --git a/src/lread.c b/src/lread.c
index 1cb941e84fc..b1af2531b52 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -3523,25 +3523,32 @@ bytecode_from_rev_list (Lisp_Object elems, Lisp_Object
readcharfun)
}
}
- if (!(size >= COMPILED_STACK_DEPTH + 1 && size <= COMPILED_INTERACTIVE + 1
+ if (!(size >= COMPILED_STACK_DEPTH && size <= COMPILED_INTERACTIVE + 1
&& (FIXNUMP (vec[COMPILED_ARGLIST])
|| CONSP (vec[COMPILED_ARGLIST])
|| NILP (vec[COMPILED_ARGLIST]))
- && STRINGP (vec[COMPILED_BYTECODE])
- && VECTORP (vec[COMPILED_CONSTANTS])
- && FIXNATP (vec[COMPILED_STACK_DEPTH])))
+ && ((STRINGP (vec[COMPILED_BYTECODE]) /* Byte-code function. */
+ && VECTORP (vec[COMPILED_CONSTANTS])
+ && size > COMPILED_STACK_DEPTH
+ && (FIXNATP (vec[COMPILED_STACK_DEPTH])))
+ || (CONSP (vec[COMPILED_BYTECODE]) /* Interpreted function. */
+ && (CONSP (vec[COMPILED_CONSTANTS])
+ || NILP (vec[COMPILED_CONSTANTS]))))))
invalid_syntax ("Invalid byte-code object", readcharfun);
- if (STRING_MULTIBYTE (vec[COMPILED_BYTECODE]))
- /* BYTESTR must have been produced by Emacs 20.2 or earlier
- because it produced a raw 8-bit string for byte-code and
- now such a byte-code string is loaded as multibyte with
- raw 8-bit characters converted to multibyte form.
- Convert them back to the original unibyte form. */
- vec[COMPILED_BYTECODE] = Fstring_as_unibyte (vec[COMPILED_BYTECODE]);
-
- /* Bytecode must be immovable. */
- pin_string (vec[COMPILED_BYTECODE]);
+ if (STRINGP (vec[COMPILED_BYTECODE]))
+ {
+ if (STRING_MULTIBYTE (vec[COMPILED_BYTECODE]))
+ /* BYTESTR must have been produced by Emacs 20.2 or earlier
+ because it produced a raw 8-bit string for byte-code and
+ now such a byte-code string is loaded as multibyte with
+ raw 8-bit characters converted to multibyte form.
+ Convert them back to the original unibyte form. */
+ vec[COMPILED_BYTECODE] = Fstring_as_unibyte (vec[COMPILED_BYTECODE]);
+
+ /* Bytecode must be immovable. */
+ pin_string (vec[COMPILED_BYTECODE]);
+ }
XSETPVECTYPE (XVECTOR (obj), PVEC_COMPILED);
return obj;
diff --git a/src/profiler.c b/src/profiler.c
index 5a6a8b48f6b..914843c521a 100644
--- a/src/profiler.c
+++ b/src/profiler.c
@@ -677,10 +677,6 @@ the same lambda expression, or are really unrelated
function. */)
res = true;
else if (COMPILEDP (f1) && COMPILEDP (f2))
res = EQ (AREF (f1, COMPILED_BYTECODE), AREF (f2, COMPILED_BYTECODE));
- else if (CONSP (f1) && CONSP (f2) && CONSP (XCDR (f1)) && CONSP (XCDR (f2))
- && EQ (Qclosure, XCAR (f1))
- && EQ (Qclosure, XCAR (f2)))
- res = EQ (XCDR (XCDR (f1)), XCDR (XCDR (f2)));
else
res = false;
return res ? Qt : Qnil;
diff --git a/test/lisp/erc/resources/erc-d/erc-d-tests.el
b/test/lisp/erc/resources/erc-d/erc-d-tests.el
index 78f87399afb..dda1b1ced84 100644
--- a/test/lisp/erc/resources/erc-d/erc-d-tests.el
+++ b/test/lisp/erc/resources/erc-d/erc-d-tests.el
@@ -367,8 +367,9 @@
(should (equal (funcall it) "foo3foo")))
(ert-info ("Exits clean")
- (when (listp (alist-get 'f (erc-d-dialog-vars dialog))) ; may be compiled
- (should (eq 'closure (car (alist-get 'f (erc-d-dialog-vars dialog))))))
+ (when (interpreted-function-p
+ (alist-get 'f (erc-d-dialog-vars dialog))) ; may be compiled
+ (should (aref (alist-get 'f (erc-d-dialog-vars dialog)) 2)))
(should-not (funcall it))
(should (equal (erc-d-dialog-vars dialog)
`((:a . 1)
diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el
index 1beeb77640c..d628c8be696 100644
--- a/test/lisp/help-fns-tests.el
+++ b/test/lisp/help-fns-tests.el
@@ -65,12 +65,12 @@ Return first line of the output of (describe-function-1
FUNC)."
(ert-deftest help-fns-test-lisp-defun ()
(let ((regexp (if (featurep 'native-compile)
"a subr-native-elisp in .+subr\\.el"
- "a compiled-function in .+subr\\.el"))
+ "a byte-code-function in .+subr\\.el"))
(result (help-fns-tests--describe-function 'last)))
(should (string-match regexp result))))
(ert-deftest help-fns-test-lisp-defsubst ()
- (let ((regexp "a compiled-function in .+subr\\.el")
+ (let ((regexp "a byte-code-function in .+subr\\.el")
(result (help-fns-tests--describe-function 'posn-window)))
(should (string-match regexp result))))