X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/801eda8a2a00b3f28a69ffe51b05a649fffc5c58..ae277259b1cf8d913893417e4ca284040f5a543f:/lisp/emacs-lisp/cl-macs.el diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 712a748516..a81d217e4e 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -257,11 +257,7 @@ FORM is of the form (ARGS . BODY)." (setq cl--bind-defs (cadr cl-defs)) ;; Remove "&cl-defs DEFS" from args. (setcdr cl-defs (cddr cl-defs)) - (setq args (delq '&cl-defs args)) - ;; Optimize away trivial &cl-defs. - (if (and (null (car cl--bind-defs)) - (cl-every (lambda (x) (null (cadr x))) (cdr cl--bind-defs))) - (setq cl--bind-defs nil)))) + (setq args (delq '&cl-defs args)))) (if (setq cl--bind-enquote (memq '&cl-quote args)) (setq args (delq '&cl-quote args))) (if (memq '&whole args) (error "&whole not currently implemented")) @@ -272,11 +268,19 @@ FORM is of the form (ARGS . BODY)." ;; Take away all the simple args whose parsing can be handled more ;; efficiently by a plain old `lambda' than the manual parsing generated ;; by `cl--do-arglist'. - (while (and args (symbolp (car args)) - (not (memq (car args) '(nil &rest &body &key &aux))) - (not (and (eq (car args) '&optional) - (or cl--bind-defs (consp (cadr args)))))) - (push (pop args) simple-args)) + (let ((optional nil)) + (while (and args (symbolp (car args)) + (not (memq (car args) '(nil &rest &body &key &aux))) + (or (not optional) + ;; Optional args whose default is nil are simple. + (null (nth 1 (assq (car args) (cdr cl--bind-defs))))) + (not (and (eq (car args) '&optional) (setq optional t) + (car cl--bind-defs)))) + (push (pop args) simple-args)) + (when optional + (if args (push '&optional args)) + ;; Don't keep a dummy trailing &optional without actual optional args. + (if (eq '&optional (car simple-args)) (pop simple-args)))) (or (eq cl--bind-block 'cl-none) (setq body (list `(cl-block ,cl--bind-block ,@body)))) (let* ((cl--bind-lets nil) (cl--bind-forms nil) @@ -292,7 +296,7 @@ FORM is of the form (ARGS . BODY)." ;; "manual" parsing. (let ((slen (length simple-args))) (when (memq '&optional simple-args) - (push '&optional args) (cl-decf slen)) + (cl-decf slen)) (setq header ;; Macro expansion can take place in the middle of ;; apparently harmless computation, so it should not @@ -2430,8 +2434,80 @@ Like `cl-callf', but PLACE is the second argument of FUNC, not the first. (if (symbolp func) (cons func rargs) `(funcall #',func ,@rargs)))))))) +;;;###autoload +(defmacro cl-defsubst (name args &rest body) + "Define NAME as a function. +Like `defun', except the function is automatically declared `inline' and +the arguments are immutable. +ARGLIST allows full Common Lisp conventions, and BODY is implicitly +surrounded by (cl-block NAME ...). +The function's arguments should be treated as immutable. + +\(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug cl-defun) (indent 2)) + (let* ((argns (cl--arglist-args args)) + (real-args (if (eq '&cl-defs (car args)) (cddr args) args)) + (p argns) + ;; (pbody (cons 'progn body)) + ) + (while (and p (eq (cl--expr-contains real-args (car p)) 1)) (pop p)) + `(progn + ,(if p nil ; give up if defaults refer to earlier args + `(cl-define-compiler-macro ,name + ,(if (memq '&key args) + `(&whole cl-whole &cl-quote ,@args) + (cons '&cl-quote args)) + (cl--defsubst-expand + ',argns '(cl-block ,name ,@body) + ;; We used to pass `simple' as + ;; (not (or unsafe (cl-expr-access-order pbody argns))) + ;; But this is much too simplistic since it + ;; does not pay attention to the argvs (and + ;; cl-expr-access-order itself is also too naive). + nil + ,(and (memq '&key args) 'cl-whole) nil ,@argns))) + (cl-defun ,name ,args ,@body)))) + +(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs) + (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole + (if (cl--simple-exprs-p argvs) (setq simple t)) + (let* ((substs ()) + (lets (delq nil + (cl-mapcar (lambda (argn argv) + (if (or simple (macroexp-const-p argv)) + (progn (push (cons argn argv) substs) + nil) + (list argn argv))) + argns argvs)))) + ;; FIXME: `sublis/subst' will happily substitute the symbol + ;; `argn' in places where it's not used as a reference + ;; to a variable. + ;; FIXME: `sublis/subst' will happily copy `argv' to a different + ;; scope, leading to name capture. + (setq body (cond ((null substs) body) + ((null (cdr substs)) + (cl-subst (cdar substs) (caar substs) body)) + (t (cl--sublis substs body)))) + (if lets `(let ,lets ,body) body)))) + +(defun cl--sublis (alist tree) + "Perform substitutions indicated by ALIST in TREE (non-destructively)." + (let ((x (assq tree alist))) + (cond + (x (cdr x)) + ((consp tree) + (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree)))) + (t tree)))) + ;;; Structures. +(defmacro cl--find-class (type) + `(get ,type 'cl--class)) + +;; Rather than hard code cl-structure-object, we indirect through this variable +;; for bootstrapping reasons. +(defvar cl--struct-default-parent nil) + ;;;###autoload (defmacro cl-defstruct (struct &rest descs) "Define a struct type. @@ -2487,6 +2563,7 @@ non-nil value, that slot cannot be set via `setf'. (tag (intern (format "cl-struct-%s" name))) (tag-symbol (intern (format "cl-struct-%s-tags" name))) (include-descs nil) + (include-name nil) (type nil) (named nil) (forms nil) @@ -2516,12 +2593,14 @@ non-nil value, that slot cannot be set via `setf'. ((eq opt :predicate) (if args (setq predicate (car args)))) ((eq opt :include) - (when include (error "Can't :include more than once")) - (setq include (car args) - include-descs (mapcar (function - (lambda (x) - (if (consp x) x (list x)))) - (cdr args)))) + ;; FIXME: Actually, we can include more than once as long as + ;; we include EIEIO classes rather than cl-structs! + (when include-name (error "Can't :include more than once")) + (setq include-name (car args)) + (setq include-descs (mapcar (function + (lambda (x) + (if (consp x) x (list x)))) + (cdr args)))) ((eq opt :print-function) (setq print-func (car args))) ((eq opt :type) @@ -2533,19 +2612,21 @@ non-nil value, that slot cannot be set via `setf'. descs))) (t (error "Slot option %s unrecognized" opt))))) + (unless (or include-name type) + (setq include-name cl--struct-default-parent)) + (when include-name (setq include (cl--struct-get-class include-name))) (if print-func (setq print-func `(progn (funcall #',print-func cl-x cl-s cl-n) t)) - (or type (and include (not (get include 'cl-struct-print))) + (or type (and include (not (cl--struct-class-print include))) (setq print-auto t print-func (and (or (not (or include type)) (null print-func)) `(progn (princ ,(format "#S(%s" name) cl-s)))))) (if include - (let ((inc-type (get include 'cl-struct-type)) - (old-descs (get include 'cl-struct-slots))) - (or inc-type (error "%s is not a struct name" include)) - (and type (not (eq (car inc-type) type)) + (let* ((inc-type (cl--struct-class-type include)) + (old-descs (cl-struct-slot-info include))) + (and type (not (eq inc-type type)) (error ":type disagrees with :include for %s" name)) (while include-descs (setcar (memq (or (assq (caar include-descs) old-descs) @@ -2554,9 +2635,9 @@ non-nil value, that slot cannot be set via `setf'. old-descs) (pop include-descs))) (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) - type (car inc-type) - named (assq 'cl-tag-slot descs)) - (if (cadr inc-type) (setq tag name named t))) + type inc-type + named (if type (assq 'cl-tag-slot descs) 'true)) + (if (cl--struct-class-named include) (setq tag name named t))) (if type (progn (or (memq type '(vector list)) @@ -2601,8 +2682,8 @@ non-nil value, that slot cannot be set via `setf'. (declare (side-effect-free t)) ,@(and pred-check (list `(or ,pred-check - (error "%s accessing a non-%s" - ',accessor ',name)))) + (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)))) @@ -2678,18 +2759,43 @@ non-nil value, that slot cannot be set via `setf'. `(progn (defvar ,tag-symbol) ,@(nreverse forms) + ;; Call cl-struct-define during compilation as well, so that + ;; a subsequent cl-defstruct in the same file can correctly include this + ;; struct as a parent. (eval-and-compile - (cl-struct-define ',name ,docstring ',include + (cl-struct-define ',name ,docstring ',include-name ',type ,(eq named t) ',descs ',tag-symbol ',tag ',print-auto)) ',name))) +;;; Add cl-struct support to pcase + +;;;###autoload +(pcase-defmacro cl-struct (type &rest fields) + "Pcase patterns to match cl-structs. +Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of +field NAME is matched against UPAT, or they can be of the form NAME which +is a shorthand for (NAME NAME)." + ;; FIXME: This works well for a destructuring pcase-let, but for straight + ;; pcase, it suffers seriously from a lack of support for cl-typep in + ;; pcase--mutually-exclusive-p. + `(and (pred (pcase--swap cl-typep ',type)) + ,@(mapcar + (lambda (field) + (let* ((name (if (consp field) (car field) field)) + (pat (if (consp field) (cadr field) field))) + `(app ,(if (eq (cl-struct-sequence-type type) 'list) + `(nth ,(cl-struct-slot-offset type name)) + `(pcase--flip aref ,(cl-struct-slot-offset type name))) + ,pat))) + fields))) + (defun cl-struct-sequence-type (struct-type) "Return the sequence used to build STRUCT-TYPE. STRUCT-TYPE is a symbol naming a struct type. Return 'vector or 'list, or nil if STRUCT-TYPE is not a struct type. " (declare (side-effect-free t) (pure t)) - (car (get struct-type 'cl-struct-type))) + (cl--struct-class-type (cl--struct-get-class struct-type))) (defun cl-struct-slot-info (struct-type) "Return a list of slot names of struct STRUCT-TYPE. @@ -2698,7 +2804,19 @@ slot name symbol and OPTS is a list of slot options given to `cl-defstruct'. Dummy slots that represent the struct name and slots skipped by :initial-offset may appear in the list." (declare (side-effect-free t) (pure t)) - (get struct-type 'cl-struct-slots)) + (let* ((class (cl--struct-get-class struct-type)) + (slots (cl--struct-class-slots class)) + (type (cl--struct-class-type class)) + (descs (if type () (list '(cl-tag-slot))))) + (dotimes (i (length slots)) + (let ((slot (aref slots i))) + (push `(,(cl--slot-descriptor-name slot) + ,(cl--slot-descriptor-initform slot) + ,@(if (not (eq (cl--slot-descriptor-type slot) t)) + `(:type ,(cl--slot-descriptor-type slot))) + ,@(cl--slot-descriptor-props slot)) + descs))) + (nreverse descs))) (defun cl-struct-slot-offset (struct-type slot-name) "Return the offset of slot SLOT-NAME in STRUCT-TYPE. @@ -2707,9 +2825,8 @@ the structure data type and is adjusted for any structure name and :initial-offset slots. Signal error if struct STRUCT-TYPE does not contain SLOT-NAME." (declare (side-effect-free t) (pure t)) - (or (cl-position slot-name - (cl-struct-slot-info struct-type) - :key #'car :test #'eq) + (or (gethash slot-name + (cl--class-index-table (cl--struct-get-class struct-type))) (error "struct %s has no slot %s" struct-type slot-name))) (defvar byte-compile-function-environment) @@ -2894,70 +3011,6 @@ macro that returns its `&whole' argument." (if cl-found (setcdr cl-found t))) `(throw ,cl-tag ,cl-value)) -;;;###autoload -(defmacro cl-defsubst (name args &rest body) - "Define NAME as a function. -Like `defun', except the function is automatically declared `inline' and -the arguments are immutable. -ARGLIST allows full Common Lisp conventions, and BODY is implicitly -surrounded by (cl-block NAME ...). -The function's arguments should be treated as immutable. - -\(fn NAME ARGLIST [DOCSTRING] BODY...)" - (declare (debug cl-defun) (indent 2)) - (let* ((argns (cl--arglist-args args)) - (p argns) - ;; (pbody (cons 'progn body)) - ) - (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p)) - `(progn - ,(if p nil ; give up if defaults refer to earlier args - `(cl-define-compiler-macro ,name - ,(if (memq '&key args) - `(&whole cl-whole &cl-quote ,@args) - (cons '&cl-quote args)) - (cl--defsubst-expand - ',argns '(cl-block ,name ,@body) - ;; We used to pass `simple' as - ;; (not (or unsafe (cl-expr-access-order pbody argns))) - ;; But this is much too simplistic since it - ;; does not pay attention to the argvs (and - ;; cl-expr-access-order itself is also too naive). - nil - ,(and (memq '&key args) 'cl-whole) nil ,@argns))) - (cl-defun ,name ,args ,@body)))) - -(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs) - (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole - (if (cl--simple-exprs-p argvs) (setq simple t)) - (let* ((substs ()) - (lets (delq nil - (cl-mapcar (lambda (argn argv) - (if (or simple (macroexp-const-p argv)) - (progn (push (cons argn argv) substs) - nil) - (list argn argv))) - argns argvs)))) - ;; FIXME: `sublis/subst' will happily substitute the symbol - ;; `argn' in places where it's not used as a reference - ;; to a variable. - ;; FIXME: `sublis/subst' will happily copy `argv' to a different - ;; scope, leading to name capture. - (setq body (cond ((null substs) body) - ((null (cdr substs)) - (cl-subst (cdar substs) (caar substs) body)) - (t (cl--sublis substs body)))) - (if lets `(let ,lets ,body) body)))) - -(defun cl--sublis (alist tree) - "Perform substitutions indicated by ALIST in TREE (non-destructively)." - (let ((x (assq tree alist))) - (cond - (x (cdr x)) - ((consp tree) - (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree)))) - (t tree)))) - ;; Compile-time optimizations for some functions defined in this package. (defun cl--compiler-macro-member (form a list &rest keys)