[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/interpreted-function 29034c6bc7f: interpreted-function
|
From: |
Stefan Monnier |
|
Subject: |
scratch/interpreted-function 29034c6bc7f: interpreted-function |
|
Date: |
Mon, 11 Mar 2024 16:14:54 -0400 (EDT) |
branch: scratch/interpreted-function
commit 29034c6bc7fb5c2e0db56702ae8641fa55784d24
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
interpreted-function
---
lisp/bind-key.el | 23 ++----
lisp/emacs-lisp/byte-opt.el | 6 +-
lisp/emacs-lisp/bytecomp.el | 31 ++++----
lisp/emacs-lisp/cconv.el | 22 +++---
lisp/emacs-lisp/cl-macs.el | 2 +
lisp/emacs-lisp/cl-preloaded.el | 15 +++-
lisp/emacs-lisp/cl-print.el | 33 +++++++-
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 | 6 +-
lisp/emacs-lisp/oclosure.el | 84 ++++++++------------
lisp/emacs-lisp/pcase.el | 18 ++++-
lisp/emacs-lisp/pp.el | 6 --
lisp/gnus/legacy-gnus-agent.el | 45 -----------
lisp/help-fns.el | 30 ++++---
lisp/help.el | 9 +--
lisp/profiler.el | 12 ++-
lisp/simple.el | 2 +-
lisp/subr.el | 3 +-
src/alloc.c | 23 +++---
src/callint.c | 6 +-
src/data.c | 40 ++++++++--
src/eval.c | 112 ++++++++++++++++++++-------
src/lread.c | 35 +++++----
src/puresize.h | 2 +-
src/regex-emacs.c | 12 ++-
test/lisp/erc/resources/erc-d/erc-d-tests.el | 5 +-
29 files changed, 338 insertions(+), 256 deletions(-)
diff --git a/lisp/bind-key.el b/lisp/bind-key.el
index 378ad69b2bc..1539a038b87 100644
--- a/lisp/bind-key.el
+++ b/lisp/bind-key.el
@@ -454,30 +454,19 @@ other modes. See `override-global-mode'."
(defun bind-key--get-binding-description (elem)
(cond
- ((listp elem)
- (cond
- ((memq (car elem) '(lambda function))
- (if (and bind-key-describe-special-forms
- (stringp (nth 2 elem)))
- (nth 2 elem)
- "#<lambda>"))
- ((eq 'closure (car elem))
- (if (and bind-key-describe-special-forms
- (stringp (nth 3 elem)))
- (nth 3 elem)
- "#<closure>"))
- ((eq 'keymap (car elem))
+ ((eq 'keymap (car-safe elem))
"#<keymap>")
- (t
- elem)))
;; must be a symbol, non-symbol keymap case covered above
((and bind-key-describe-special-forms (keymapp elem))
(let ((doc (get elem 'variable-documentation)))
(if (stringp doc) doc elem)))
((symbolp elem)
elem)
- (t
- "#<byte-compiled lambda>")))
+ ((functionp elem)
+ (cond
+ ((compiled-function-p elem) "#<compiled-function>")
+ (t "#<function>")))
+ (t)))
(defun bind-key--compare-keybindings (l r)
(let* ((regex bind-key-segregation-regexp)
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index f75be3f71ad..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
@@ -3116,7 +3117,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to
be of no importance."
;;
(eval-when-compile
(or (compiled-function-p (symbol-function 'byte-optimize-form))
- (assq 'byte-code (symbol-function 'byte-optimize-form))
(let ((byte-optimize nil)
(byte-compile-warnings nil))
(mapc (lambda (x)
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index cf0e6d600dd..13638cba5be 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))
@@ -5542,6 +5546,8 @@ invoked interactively."
(format " ==> %s" f))
((byte-code-function-p f)
"<compiled function>")
+ ((interpreted-function-p f)
+ "<interpreted function>")
((not (consp f))
"<malformed function>")
((eq 'macro (car f))
@@ -5550,11 +5556,8 @@ invoked interactively."
(assq 'byte-code (cdr (cdr (cdr f)))))
" <compiled macro>"
" <macro>"))
- ((assq 'byte-code (cdr (cdr f)))
- ;; FIXME: Can this still happen?
- "<compiled lambda>")
((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-macs.el b/lisp/emacs-lisp/cl-macs.el
index be477b7a6df..f5ade433709 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3470,7 +3470,9 @@ Of course, we really can't know that for sure, so it's
just a heuristic."
(boolean . booleanp)
(bool-vector . bool-vector-p)
(buffer . bufferp)
+ (closure . closurep)
(byte-code-function . byte-code-function-p)
+ (interpreted-function . interpreted-function-p)
(character . natnump)
(char-table . char-table-p)
(command . commandp)
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 5743684fa89..cb13d6b7c1f 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -306,6 +306,7 @@
(:constructor nil)
(:constructor built-in-class--make (name docstring parents))
(:copier nil))
+ "Type of built-in types."
)
(defmacro cl--define-built-in-type (name parents &optional docstring &rest
_slots)
@@ -413,17 +414,23 @@ For this build of Emacs it's %dbit."
"Abstract super type 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 (compiled-function)
+(cl--define-built-in-type interpreted-function (closure)
+ "Type of functions that have not been compiled.")
+(cl--define-built-in-type subr (atom)
"Abstract type of functions compiled to machine code.")
(cl--define-built-in-type module-function (function)
"Type of functions provided via the module API.")
(cl--define-built-in-type interpreted-function (function)
"Type of functions that have not been compiled.")
-(cl--define-built-in-type subr-native-elisp (subr)
+(cl--define-built-in-type special-form (subr)
+ "Type of the core syntactic elements of the Emacs Lisp language.")
+(cl--define-built-in-type subr-native-elisp (subr compiled-function)
"Type of function that have been compiled by the native compiler.")
-(cl--define-built-in-type subr-primitive (subr)
+(cl--define-built-in-type subr-primitive (subr compiled-function)
"Type of functions hand written in C.")
(unless (cl--class-parents (cl--find-class 'cl-structure-object))
diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index c35353ec3d0..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)
@@ -444,7 +475,7 @@ primitives such as `prin1'.")
(defun cl-print--preprocess (object)
(let ((print-number-table (make-hash-table :test 'eq :rehash-size 2.0)))
- (if (fboundp 'print--preprocess)
+ (if (fboundp 'print--preprocess) ;Emacsā„26
;; Use the predefined C version if available.
(print--preprocess object) ;Fill print-number-table!
(let ((cl-print--number-index 0))
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 7524ab18e58..65d1c2c699c 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -185,15 +185,15 @@ 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)))
- (if (macroexp-const-p form)
+ (if (macroexp-const-p form) ;Common case: a string.
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 977d5735171..77e082811c1 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -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 the `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 the `cconv.el'
+ ;; should have optimized away the call to this function.
+ oclosure)
(defun oclosure--copy (oclosure mutlist &rest args)
- (if (byte-code-function-p oclosure)
+ (cl-assert (closurep oclosure))
+ (if (stringp (aref oclosure 1)) ;Actual byte-code
(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/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el
index 569f70ca604..c452e171a30 100644
--- a/lisp/emacs-lisp/pp.el
+++ b/lisp/emacs-lisp/pp.el
@@ -518,12 +518,6 @@ the bounds of a region containing Lisp code to
pretty-print."
;; on a single line.
(when doc
(setq indent (1- doc)))
- ;; Special-case closures -- these shouldn't really exist in actual
- ;; source code, so there's no indentation information. But make
- ;; them output slightly better.
- (when (and (not indent)
- (eq sym 'closure))
- (setq indent 0))
(pp--insert "(" sym)
(pop sexp)
;; Get the first entries on the first line.
diff --git a/lisp/gnus/legacy-gnus-agent.el b/lisp/gnus/legacy-gnus-agent.el
index d4f08c72de8..2b1a3103128 100644
--- a/lisp/gnus/legacy-gnus-agent.el
+++ b/lisp/gnus/legacy-gnus-agent.el
@@ -210,51 +210,6 @@ converted to the compressed format."
;; Therefore, hide the default prompt.
(gnus-convert-mark-converter-prompt 'gnus-agent-unlist-expire-days t)
-(defun gnus-agent-unhook-expire-days (_converting-to)
- "Remove every lambda from `gnus-group-prepare-hook' that mention the
-symbol `gnus-agent-do-once' in their definition. This should NOT be
-necessary as gnus-agent.el no longer adds them. However, it is
-possible that the hook was persistently saved."
- (let ((h t)) ; Iterate from bgn of hook.
- (while h
- (let ((func (progn (when (eq h t)
- ;; Init h to list of functions.
- (setq h (cond ((listp gnus-group-prepare-hook)
- gnus-group-prepare-hook)
- ((boundp 'gnus-group-prepare-hook)
- (list gnus-group-prepare-hook)))))
- (pop h))))
-
- (when (cond ((byte-code-function-p func)
- ;; Search def. of compiled function for
- ;; gnus-agent-do-once string.
- (let* (definition
- print-level
- print-length
- (standard-output
- (lambda (char)
- (setq definition (cons char definition)))))
- (princ func) ; Populates definition with reversed list
- ; of characters.
- (let* ((i (length definition))
- (s (make-string i 0)))
- (while definition
- (aset s (setq i (1- i)) (pop definition)))
-
- (string-match "\\bgnus-agent-do-once\\b" s))))
- ((listp func)
- (eq (cadr (nth 2 func)) 'gnus-agent-do-once) ; Handles
eval'd lambda.
- ))
-
- (remove-hook 'gnus-group-prepare-hook func)
- ;; I don't what remove-hook is going to actually do to the
- ;; hook list so start over from the beginning.
- (setq h t))))))
-
-;; gnus-agent-unhook-expire-days is safe in that it does not modify
-;; the .newsrc.eld file.
-(gnus-convert-mark-converter-prompt 'gnus-agent-unhook-expire-days t)
-
(provide 'legacy-gnus-agent)
;;; legacy-gnus-agent.el ends here
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 15d87f9925c..cda12b292de 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -1061,10 +1061,10 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED
REAL-DEF)."
(concat
"an autoloaded " (if (commandp def)
"interactive "))
- (if (commandp def) "an interactive " "a "))))
-
- ;; Print what kind of function-like object FUNCTION is.
- (princ (cond ((or (stringp def) (vectorp def))
+ (if (commandp def) "an interactive " "a ")))
+ ;; Print what kind of function-like object FUNCTION is.
+ (description
+ (cond ((or (stringp def) (vectorp def))
"a keyboard macro")
((and (symbolp function)
(get function 'reader-construct))
@@ -1073,12 +1073,6 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED
REAL-DEF)."
;; aliases before functions.
(aliased
(format-message "an alias for `%s'" real-def))
- ((subr-native-elisp-p def)
- (concat beg "native-compiled Lisp function"))
- ((subrp def)
- (concat beg (if (eq 'unevalled (cdr (subr-arity def)))
- "special form"
- "built-in function")))
((autoloadp def)
(format "an autoloaded %s"
(cond
@@ -1092,12 +1086,12 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED
REAL-DEF)."
;; need to check macros before functions.
(macrop function))
(concat beg "Lisp macro"))
- ((byte-code-function-p def)
- (concat beg "byte-compiled Lisp function"))
- ((module-function-p def)
- (concat beg "module function"))
- ((memq (car-safe def) '(lambda closure))
- (concat beg "Lisp function"))
+ ((atom def)
+ (concat beg (format "`%s'"
+ (make-text-button
+ (symbol-name (type-of def)) nil
+ 'type 'cl-help-type
+ 'help-args (list (type-of def))))))
((keymapp def)
(let ((is-full nil)
(elts (cdr-safe def)))
@@ -1107,7 +1101,9 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED
REAL-DEF)."
elts nil))
(setq elts (cdr-safe elts)))
(concat beg (if is-full "keymap" "sparse keymap"))))
- (t "")))
+ (t ""))))
+ (with-current-buffer standard-output
+ (insert description))
(if (and aliased (not (fboundp real-def)))
(princ ",\nwhich is not defined.")
diff --git a/lisp/help.el b/lisp/help.el
index c6a1e3c6bd9..8fcdf2a14f7 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1661,11 +1661,11 @@ Return nil if the key sequence is too long."
((byte-code-function-p definition)
(insert (format "[%s]\n"
(buttonize "byte-code" #'disassemble definition))))
- ((and (consp definition)
- (memq (car definition) '(closure lambda)))
+ ((or (eq (car-safe definition) 'lambda) (interpreted-function-p
definition))
+ ;; FIXME: Use a `function-name' primitive?
(insert (format "[%s]\n"
(buttonize
- (symbol-name (car definition))
+ "interpreted function"
(lambda (_)
(pp-display-expression
definition "*Help Source*" t))
@@ -2359,9 +2359,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 80f84037a63..016e33fdc77 100644
--- a/lisp/profiler.el
+++ b/lisp/profiler.el
@@ -107,10 +107,11 @@
(defun profiler-format-entry (entry)
"Format ENTRY in human readable string.
ENTRY would be a function name of a function itself."
- (cond ((memq (car-safe entry) '(closure lambda))
+ ;; FIXME: Use a `function-name' primitive?
+ (cond ((eq (car-safe entry) 'lambda)
(format "#<lambda %#x>" (sxhash entry)))
- ((byte-code-function-p entry)
- (format "#<compiled %#x>" (sxhash entry)))
+ ((closurep entry)
+ (format "#<closure %#x>" (sxhash entry)))
((or (subrp entry) (symbolp entry) (stringp entry))
(format "%s" entry))
(t
@@ -296,10 +297,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 f127290231b..b45b1d85f35 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/lisp/subr.el b/lisp/subr.el
index ce933e3bfdc..4acffb8232f 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -4517,7 +4517,8 @@ Otherwise, return nil."
Does not distinguish between functions implemented in machine code
or byte-code."
(declare (side-effect-free error-free))
- (or (subrp object) (byte-code-function-p object)))
+ (or (subrp object)
+ (byte-code-function-p object)))
(defun field-at-pos (pos)
"Return the field at position POS, taking stickiness etc into account."
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 35f4c82c68f..b6624babe70 100644
--- a/src/data.c
+++ b/src/data.c
@@ -224,8 +224,13 @@ for example, (type-of 1) returns `integer'. */)
case PVEC_WINDOW_CONFIGURATION: return Qwindow_configuration;
case PVEC_PROCESS: return Qprocess;
case PVEC_WINDOW: return Qwindow;
- case PVEC_SUBR: return Qsubr;
- case PVEC_COMPILED: return Qcompiled_function;
+ case PVEC_SUBR:
+ return SUBR_NATIVE_COMPILEDP (object) ? Qsubr_native_elisp
+ : XSUBR (object)->max_args == UNEVALLED ? Qspecial_form
+ : Qsubr_primitive;
+ 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;
@@ -495,12 +500,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;
}
@@ -4217,8 +4242,11 @@ syms_of_data (void)
DEFSYM (Qwindow_configuration, "window-configuration");
DEFSYM (Qprocess, "process");
DEFSYM (Qwindow, "window");
- DEFSYM (Qsubr, "subr");
- DEFSYM (Qcompiled_function, "compiled-function");
+ DEFSYM (Qspecial_form, "special-form");
+ DEFSYM (Qsubr_primitive, "subr-primitive");
+ DEFSYM (Qsubr_native_elisp, "subr-native-elisp");
+ DEFSYM (Qbyte_code_function, "byte-code-function");
+ DEFSYM (Qinterpreted_function, "interpreted-function");
DEFSYM (Qbuffer, "buffer");
DEFSYM (Qframe, "frame");
DEFSYM (Qvector, "vector");
@@ -4282,6 +4310,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 95eb21909d2..59c906fc425 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 49683d02401..304ae78fd7d 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/puresize.h b/src/puresize.h
index ac5d2da30dc..2a716872832 100644
--- a/src/puresize.h
+++ b/src/puresize.h
@@ -47,7 +47,7 @@ INLINE_HEADER_BEGIN
#endif
#ifndef BASE_PURESIZE
-#define BASE_PURESIZE (2750000 + SYSTEM_PURESIZE_EXTRA +
SITELOAD_PURESIZE_EXTRA)
+#define BASE_PURESIZE (3000000 + SYSTEM_PURESIZE_EXTRA +
SITELOAD_PURESIZE_EXTRA)
#endif
/* Increase BASE_PURESIZE by a ratio depending on the machine's word size. */
diff --git a/src/regex-emacs.c b/src/regex-emacs.c
index 0ec0c6eb63f..34bd66c5316 100644
--- a/src/regex-emacs.c
+++ b/src/regex-emacs.c
@@ -2830,7 +2830,7 @@ group_in_compile_stack (compile_stack_type compile_stack,
regnum_t regnum)
To guarantee termination, at each iteration, either LOOP_BEG should
get bigger, or it should stay the same and P should get bigger. */
static bool
-forall_firstchar_1 (re_char *p, re_char *pend,
+forall_firstchar_1 (struct re_pattern_buffer *bufp, re_char *p, re_char *pend,
re_char *loop_beg, re_char *loop_end,
bool f (const re_char *p, void *arg), void *arg)
{
@@ -2946,11 +2946,17 @@ forall_firstchar_1 (re_char *p, re_char *pend,
{
#if ENABLE_CHECKING
fprintf (stderr, "FORALL_FIRSTCHAR: Broken assumption2!!\n");
+ fprintf (stderr, "Destinations: %ld and %ld!!\n",
+ newp1 - bufp->buffer,
+ newp2 - bufp->buffer);
+ fprintf (stderr, "loop_beg = %ld and loop_end = %ld!!\n",
+ loop_beg - bufp->buffer,
+ loop_end - bufp->buffer);
#endif
return false;
}
- if (!forall_firstchar_1 (newp2, pend, loop_beg, loop_end, f, arg))
+ if (!forall_firstchar_1 (bufp, newp2, pend, loop_beg, loop_end, f,
arg))
return false;
do_jump:
@@ -3046,7 +3052,7 @@ forall_firstchar (struct re_pattern_buffer *bufp, re_char
*p, re_char *pend,
{
eassert (!bufp || bufp->used);
eassert (pend || bufp->used);
- return forall_firstchar_1 (p, pend,
+ return forall_firstchar_1 (bufp, p, pend,
bufp ? bufp->buffer - 1 : p,
bufp ? bufp->buffer + bufp->used + 1 : pend,
f, arg);
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)