diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index 1b2a21e160c..2721c2ce4a0 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -2609,7 +2609,9 @@ as a compiler macro. The function will accept the argument list If present, @var{doc} should be the function's documentation string (@pxref{Function Documentation}); @var{declare}, if present, should be a @code{declare} form (@pxref{Declare Form}) specifying the function's -metadata. +metadata. In addition to the usual declarations, @var{declare} +can include @code{(noinline @var{NOINLINE})} when a non-@code{nil} +@var{NOINLINE} prevents Emacs from inlining the defined function. @end defmac Functions defined via @code{define-inline} have several advantages diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 63d85623fbe..2c2451e14cd 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -676,7 +676,7 @@ its argument list allows full Common Lisp conventions." ((eq keys t) nil) ;No &keys at all ((null keys) ;A &key but no actual keys specified. (push `(when ,restarg - (error ,(format "Keyword argument %%s not one of %s" + (error ,(format "Keyword argument %%S not one of %S" keys) (car ,restarg))) cl--bind-forms)) @@ -693,7 +693,7 @@ its argument list allows full Common Lisp conventions." (setq ,var nil)) (t (error - ,(format "Keyword argument %%s not one of %s" + ,(format "Keyword argument %%S not one of %S" keys) (car ,var))))))) (push `(let ((,var ,restarg)) ,check) cl--bind-forms))))) @@ -1888,9 +1888,7 @@ An implicit nil block is established around the loop. \(fn (VAR LIST [RESULT]) BODY...)" (declare (debug ((symbolp form &optional form) cl-declarations body)) (indent 1)) - (let ((loop `(dolist ,spec ,@body))) - (if (advice-member-p 'cl--wrap-in-nil-block 'dolist) - loop `(cl-block nil ,loop)))) + `(cl-block nil (dolist ,spec ,@body))) ;;;###autoload (defmacro cl-dotimes (spec &rest body) @@ -1901,9 +1899,7 @@ nil. \(fn (VAR COUNT [RESULT]) BODY...)" (declare (debug cl-dolist) (indent 1)) - (let ((loop `(dotimes ,spec ,@body))) - (if (advice-member-p 'cl--wrap-in-nil-block 'dotimes) - loop `(cl-block nil ,loop)))) + `(cl-block nil (dotimes ,spec ,@body))) (defvar cl--tagbody-alist nil) @@ -3127,8 +3123,7 @@ To see the documentation for a defined struct type, use (include-name nil) (type nil) ;nil here means not specified explicitly. (named nil) - (cldefsym (if cl--struct-inline 'cl-defsubst 'cl-defun)) - (defsym (if cl--struct-inline 'cl-defsubst 'defun)) + (noinline (not cl--struct-inline)) (forms nil) (docstring (if (stringp (car descs)) (pop descs))) (dynbound-slotnames '()) @@ -3175,8 +3170,7 @@ To see the documentation for a defined struct type, use (error "Invalid :type specifier: %s" type))) ((eq opt :named) (setq named t)) - ((eq opt :noinline) - (setq defsym 'defun) (setq cldefsym 'cl-defun)) + ((eq opt :noinline) (setq noinline t)) ((eq opt :initial-offset) (setq descs (nconc (make-list (car args) '(cl-skip-slot)) descs))) @@ -3228,30 +3222,40 @@ To see the documentation for a defined struct type, use descs))))) (cond ((null type) ;Record type. - `(memq (type-of cl-x) ,tag-symbol)) + (lambda (var) `(memq (type-of ,var) ,tag-symbol))) ((eq type 'vector) - `(and (vectorp cl-x) - (>= (length cl-x) ,(length descs)) - (memq (aref cl-x ,pos) ,tag-symbol))) - ((= pos 0) `(memq (car-safe cl-x) ,tag-symbol)) - (t `(and (consp cl-x) - (memq (nth ,pos cl-x) ,tag-symbol)))))) + (lambda (var) + `(and (vectorp ,var) + (>= (length ,var) ,(length descs)) + (memq (aref ,var ,pos) ,tag-symbol)))) + ((= pos 0) + (lambda (var) `(memq (car-safe ,var) ,tag-symbol))) + (t (lambda (var) `(and (consp ,var) + (memq (nth ,pos ,var) + ,tag-symbol))))))) pred-check (and pred-form (> safety 0) - (if (and (eq (caadr pred-form) 'vectorp) - (= safety 1)) - (cons 'and (cdddr pred-form)) - `(,predicate cl-x)))) + (lambda (var) + (let ((pf (funcall pred-form var))) + (cond + ((eq (caadr pf) 'vectorp) (nth 3 pf)) + ((eq (caadr pf) 'consp) (nth 2 pf)) + (t `(,predicate ,var))))))) (when pred-form (push `(eval-and-compile ;; Define the predicate to be effective at compile time ;; as native comp relies on `cl-typep' that relies on ;; predicates to be defined as they are registered in ;; cl-deftype-satisfies. - (,defsym ,predicate (cl-x) - (declare (side-effect-free error-free) (pure t)) - ,(if (eq (car pred-form) 'and) - (append pred-form '(t)) - `(and ,pred-form t))) + (define-inline ,predicate (x) + (declare (side-effect-free error-free) (pure t) + (noinline ,noinline)) + ,(let* ((varexp ',x) + (pf (funcall pred-form varexp)) + (body (if (eq (car pf) 'and) + (append pf '(t)) + `(and ,pf t)))) + `(inline-letevals (x) + (inline-quote ,body)))) (define-symbol-prop ',name 'cl-deftype-satisfies ',predicate)) forms)) (let ((pos 0) (descp descs)) @@ -3264,26 +3268,29 @@ To see the documentation for a defined struct type, use (progn (push nil slots) (push (and (eq slot 'cl-tag-slot) `',tag) - defaults)) + defaults)) (if (assq slot descp) (error "Duplicate slots named %s in %s" slot name)) (let ((accessor (intern (format "%s%s" conc-name slot))) (default-value (pop desc)) (doc (plist-get desc :documentation)) (access-body - `(progn - ,@(and pred-check - (list `(or ,pred-check - (signal 'wrong-type-argument - (list ',name cl-x))))) - ,(if (memq type '(nil vector)) `(aref cl-x ,pos) - (if (= pos 0) '(car cl-x) - `(nth ,pos cl-x)))))) + (lambda (var) + `(progn + ,@(if pred-check + (let ((pc (funcall pred-check var))) + `((or ,pc + (signal 'wrong-type-argument + (list ',name ,var)))))) + ,(if (memq type '(nil vector)) + `(aref ,var ,pos) + (if (= pos 0) `(car ,var) + `(nth ,pos ,var))))))) (push slot slots) (push default-value defaults) - ;; The arg "cl-x" is referenced by name in e.g. pred-form - ;; and pred-check, so changing it is not straightforward. - (push `(,defsym ,accessor (cl-x) + ;; FIXME: If this is an inherited slot, use an alias of + ;; the parent's accessor? + (push `(define-inline ,accessor (x) ,(let ((long-docstring (format "Access slot \"%s\" of `%s' struct X." slot name))) @@ -3311,8 +3318,10 @@ To see the documentation for a defined struct type, use (if doc (concat "\n" doc) "") "\n" (format "\n\n(fn %s X)" accessor))) - (declare (side-effect-free t)) - ,access-body) + (declare (side-effect-free t) (noinline ,noinline)) + (inline-letevals (x) + (inline-quote + ,(funcall access-body ',x)))) forms) ;; FIXME: This hack is to document this as a generalized ;; variable, despite it not having the `gv-expander' @@ -3340,14 +3349,14 @@ To see the documentation for a defined struct type, use (push kw desc) (setcar defaults nil)))) (cond - ((eq defsym 'defun) + (noinline (unless (plist-get desc ':read-only) - (push `(defun ,(gv-setter accessor) (val cl-x) - (setf ,access-body val)) + (push `(defun ,(gv-setter accessor) (val x) + (setf ,(funcall access-body 'x) val)) forms))) ((plist-get desc ':read-only) (push `(gv-define-expander ,accessor - (lambda (_cl-do _cl-x) + (lambda (_do _x) (error "%s is a read-only slot" ',accessor))) forms)) (t @@ -3388,7 +3397,7 @@ To see the documentation for a defined struct type, use (make (cl-mapcar (lambda (s d) (if (memq s anames) s d)) slots defaults)) (con-fun (or type #'record))) - (push `(,cldefsym ,cname + (push `(,(if noinline 'cl-defun 'cl-defsubst) ,cname (&cl-defs (nil ,@descs) ,@args) ,(if (stringp doc) doc ;; NB. This will produce incorrect results in @@ -3423,6 +3432,9 @@ To see the documentation for a defined struct type, use (nreverse forms) `((with-suppressed-warnings ((lexical . ,dynbound-slotnames)) ,@(nreverse forms)))) + ;; Don't include cl-struct-define in the autoloads file, since ordering + ;; there is not guaranteed, so we can't be sure that the parent struct + ;; is already defined :-( :autoload-end ;; Call cl-struct-define during compilation as well, so that ;; a subsequent cl-defstruct in the same file can correctly include this @@ -3847,13 +3859,13 @@ If PARENTS is non-nil, ARGLIST must be nil." `(cl-deftype ,type (&optional min max) (list 'and ',base (if (memq min '(* nil)) t - (if (consp min) - `(satisfies . ,(lambda (val) (> val (car min)))) - `(satisfies . ,(lambda (val) (>= val min))))) + `(satisfies . ,(if (consp min) + (lambda (val) (> val (car min))) + (lambda (val) (>= val min))))) (if (memq max '(* nil)) t - (if (consp max) - `(satisfies . ,(lambda (val) (< val (car max)))) - `(satisfies . ,(lambda (val) (<= val max))))))))) + `(satisfies . ,(if (consp max) + (lambda (val) (< val (car max))) + (lambda (val) (<= val max))))))))) ;;(cl--defnumtype integer ??) ;;(cl--defnumtype float ??) ;;(cl--defnumtype number ??) diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el index 027c24c465b..7353bc5e81c 100644 --- a/lisp/emacs-lisp/inline.el +++ b/lisp/emacs-lisp/inline.el @@ -131,16 +131,25 @@ After VARS is handled, BODY is evaluated in the new environment." ;;;###autoload (defmacro define-inline (name args &rest body) "Define an inline function NAME with arguments ARGS and body in BODY. +This is halfway between `defmacro' and `defun'. BODY is used as a blueprint +both for the body of the function and for the body of the compiler-macro +used to generate the code inlined at each call site. +See Info node `(elisp)Inline Functions for more details. -This is like `defmacro', but has several advantages. -See Info node `(elisp)Defining Functions' for more details." +A (noinline t) in the `declare' form prevents the definition of the compiler macro, +for the rare case where you want to use this macro to define a function that should +not be inlined." ;; FIXME: How can this work with CL arglists? (declare (indent defun) (debug defun) (doc-string 3) - (autoload-macro expand)) ; expand to the defun on autoload gen - (let ((doc (if (stringp (car-safe body)) (list (pop body)))) - (declares (if (eq (car-safe (car-safe body)) 'declare) (pop body))) - (cm-name (intern (format "%s--inliner" name))) - (bodyexp (macroexp-progn body))) + (autoload-macro expand)) ; expand to the defun on autoload gen + (let* ((doc (if (stringp (car-safe body)) (list (pop body)))) + (declares (if (eq (car-safe (car-safe body)) 'declare) (pop body))) + (cm-name (intern (format "%s--inliner" name))) + (noinline-decl (assq 'noinline declares)) + (inline (not (cadr noinline-decl))) + (bodyexp (macroexp-progn body))) + (when noinline-decl + (setq declares (delq noinline-decl declares))) ;; If the function is autoloaded then when we load the .el file, the ;; `compiler-macro' property is already set (from loaddefs.el) and might ;; hence be called during the macroexpand-all calls below (if the function @@ -150,7 +159,8 @@ See Info node `(elisp)Defining Functions' for more details." `(progn (defun ,name ,args ,@doc - (declare (compiler-macro ,cm-name) ,@(cdr declares)) + (declare ,@(when inline `((compiler-macro ,cm-name))) + ,@(cdr declares)) ,(macroexpand-all bodyexp `((inline-quote . inline--dont-quote) ;; (inline-\` . inline--dont-quote) @@ -160,22 +170,23 @@ See Info node `(elisp)Defining Functions' for more details." (inline-const-val . inline--alwaysconst-val) (inline-error . inline--error) ,@macroexpand-all-environment))) - :autoload-end - (eval-and-compile - (defun ,cm-name ,(cons 'inline--form args) - (ignore inline--form) ;In case it's not used! - (catch 'inline--just-use - ,(macroexpand-all - bodyexp - `((inline-quote . inline--do-quote) - ;; (inline-\` . inline--do-quote) - (inline--leteval . inline--do-leteval) - (inline--letlisteval - . inline--do-letlisteval) - (inline-const-p . inline--testconst-p) - (inline-const-val . inline--getconst-val) - (inline-error . inline--warning) - ,@macroexpand-all-environment)))))))) + ,@(when inline + `(:autoload-end + (eval-and-compile + (defun ,cm-name ,(cons 'inline--form args) + (ignore inline--form) ;In case it's not used! + (catch 'inline--just-use + ,(macroexpand-all + bodyexp + `((inline-quote . inline--do-quote) + ;; (inline-\` . inline--do-quote) + (inline--leteval . inline--do-leteval) + (inline--letlisteval + . inline--do-letlisteval) + (inline-const-p . inline--testconst-p) + (inline-const-val . inline--getconst-val) + (inline-error . inline--warning) + ,@macroexpand-all-environment)))))))))) (defun inline--do-quote (exp) (pcase exp