[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/interpreted-function 4b6ae2561d5 2/2: interpreted-function
|
From: |
Stefan Monnier |
|
Subject: |
scratch/interpreted-function 4b6ae2561d5 2/2: interpreted-function |
|
Date: |
Thu, 21 Mar 2024 12:44:31 -0400 (EDT) |
branch: scratch/interpreted-function
commit 4b6ae2561d5e281489141c5000d20edb715c182e
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 | 26 ++++---
lisp/emacs-lisp/cconv.el | 22 +++---
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/edebug.el | 3 +-
lisp/emacs-lisp/lisp-mode.el | 1 -
lisp/emacs-lisp/nadvice.el | 4 +-
lisp/emacs-lisp/oclosure.el | 84 ++++++++------------
lisp/emacs-lisp/pcase.el | 18 ++++-
lisp/help.el | 4 +-
lisp/profiler.el | 5 +-
lisp/simple.el | 2 +-
src/alloc.c | 23 +++---
src/callint.c | 6 +-
src/data.c | 31 +++++++-
src/eval.c | 112 ++++++++++++++++++++-------
src/lread.c | 35 +++++----
test/lisp/erc/resources/erc-d/erc-d-tests.el | 5 +-
21 files changed, 279 insertions(+), 150 deletions(-)
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index f6df40a2d9b..f8063d23fbc 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 . ,_))
+ ((or `(lambda . ,_) (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)
(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..2821299b786 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -2896,10 +2896,13 @@ 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 ()))
+FUN should be either an interpreted closure."
+ (let ((args (aref fun 0))
+ (body (aref fun 1))
+ (env (aref fun 2))
+ (docstring (function-documentation fun))
+ (iform (interactive-form fun))
+ (renv ()))
;; Turn the function's closed vars (if any) into local let bindings.
(dolist (binding env)
(cond
@@ -2907,9 +2910,10 @@ FUN should be an interpreted closure."
(push `(,(car binding) ',(cdr binding)) renv))
((eq binding t))
(t (push `(defvar ,binding) body))))
- (if (null renv)
- `(lambda ,args ,@preamble ,@body)
- `(let ,renv (lambda ,args ,@preamble ,@body)))))
+ (let ((fun `(lambda ,args
+ ,@(if docstring (list docstring))
+ ,iform ,@body)))
+ (if (null renv) fun `(let ,renv ,fun)))))
;;;###autoload
(defun byte-compile (form)
@@ -2936,11 +2940,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))
@@ -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..26604860291 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,23 @@ 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 (listp 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))
+ (and (eq :closure-dont-trim-context (car body))
;; Check the function doesn't just return the magic keyword.
- (nthcdr 3 fun)))
+ (cdr body)))
;; 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))
+ (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 +936,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 +947,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 658f105a583..bbbaf8389ac 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -429,7 +429,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/edebug.el b/lisp/emacs-lisp/edebug.el
index 4c7dbb4ef8c..b0480c82a03 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -4258,7 +4258,8 @@ code location is known."
(push new-frame results)
(setq before-index nil
after-index nil))
- (`(,(or 'lambda 'closure) . ,_)
+ ;; FIXME: Strip instrumentation from interpreted-functions?
+ (`(lambda . ,_)
(unless skip-next-lambda
(edebug--unwrap-frame new-frame)
(edebug--add-source-info frame def-name before-index after-index)
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..65d1c2c699c 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 (or (null if) (not (interpreted-function-p function)))
if
(cl-assert (eq 'interactive (car if)))
(let ((form (cadr if)))
@@ -193,7 +193,7 @@ 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
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 4da8e61aaa7..2f7f9648a2b 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,53 @@ 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
+ (cl-assert (listp (aref oclosure 1)))
+ (cl-assert (symbolp (aref oclosure 4)))
+ (let ((env (aref oclosure 2)))
+ (apply #'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)))))
- ,@(nthcdr (1+ (length args)) env))
- ,@(nthcdr 2 oclosure)))))
+ (nthcdr 4 (append oclosure '()))))))
(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)
+ (if (closurep 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))))))
+ (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 7c1518ed966..84fc9972ba7 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1658,7 +1658,6 @@ Return nil if the key sequence is too long."
(insert "Keyboard Macro\n")))
((keymapp definition)
(insert "Prefix Command\n"))
- ;; FIXME: Use a `function-name' primitive?
;; ((byte-code-function-p definition)
;; (insert (format "[%s]\n"
;; (buttonize "byte-code" #'disassemble definition))))
@@ -2362,9 +2361,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 cc65870cdd1..921d73c6660 100644
--- a/lisp/profiler.el
+++ b/lisp/profiler.el
@@ -276,10 +276,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..18cc842dc39 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2703,7 +2703,7 @@ 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))))
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..a856767ed39 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 bytecode object either is an interpreted closure
+ 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/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)