diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 3 | ||||
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 18 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cconv.el | 38 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-preloaded.el | 15 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-print.el | 32 | ||||
| -rw-r--r-- | lisp/emacs-lisp/comp-common.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/disass.el | 6 | ||||
| -rw-r--r-- | lisp/emacs-lisp/edebug.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp-mode.el | 1 | ||||
| -rw-r--r-- | lisp/emacs-lisp/nadvice.el | 6 | ||||
| -rw-r--r-- | lisp/emacs-lisp/oclosure.el | 96 |
11 files changed, 129 insertions, 90 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index ea163723a3e..3d6b35422b8 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 @@ -1870,6 +1870,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 2704378fc84..7aae87c50dc 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2915,9 +2915,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 @@ -2954,11 +2959,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)) @@ -5148,7 +5153,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)) 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 83d9e6ee220..fa745396b02 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -444,13 +444,24 @@ For this build of Emacs it's %dbit." ) (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. +You can access the object's internals with `aref'. +The fields are used as follows: + + 0 [args] Argument list (either a list or an integer) + 1 [code] Either a byte-code string or a list of Lisp forms + 2 [constants] Either vector of constants or a lexical environment + 3 [stackdepth] Maximum amount of stack depth used by the byte-code + 4 [docstring] The documentation, or a reference to it + 5 [iform] The interactive form (if present)") +(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.") (cl--define-built-in-type module-function (function) "Type of functions provided via the module API.") -(cl--define-built-in-type interpreted-function (function) +(cl--define-built-in-type interpreted-function (closure) "Type of functions that have not been compiled.") (cl--define-built-in-type special-form (subr) "Type of the core syntactic elements of the Emacs Lisp language.") diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 39688661eb1..e8e6502e66f 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -237,6 +237,38 @@ 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))) + ;; It's tempting to print the arglist from the "usage" info in the + ;; doc (e.g. for `&key` args), but that only makes sense if we + ;; *don't* print the body, since otherwise the body will tend to + ;; refer to args that don't appear in the arglist. + (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 (documentation object 'raw))) + (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 b27ffbca908..3414bb592c0 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -4254,7 +4254,7 @@ code location is known." ((pred edebug--symbol-prefixed-p) nil) (_ (when (and skip-next-lambda - (not (memq (car-safe fun) '(closure lambda)))) + (not (interpreted-function-p fun))) (warn "Edebug--strip-instrumentation expected an interpreted function:\n%S" fun)) (unless skip-next-lambda (edebug--unwrap-frame new-frame) 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: |