mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-02-16 09:14:18 +00:00
(cl-defstruct): Use define-inline
* lisp/emacs-lisp/inline.el (define-inline): Add `noinline` declaration. * doc/lispref/functions.texi (Inline Functions): Mention it. * lisp/emacs-lisp/cl-macs.el (cl--do-arglist): Avoid %s for lists in format string. (cl-dolist, cl-dotimes): Remove obsolete optimization. (cl-defstruct): Use `define-inline` instead of `cl-defsubst` for accessors.
This commit is contained in:
Stefan Monnier
parent
90afc7aaa3
commit
ac835686b5
3 changed files with 103 additions and 78 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ??)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue