(defconst cl--lambda-list-keywords
'(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
-(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote)
-(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms)
+;; Internal hacks used in formal arg lists:
+;; - &cl-quote: Added to formal-arglists to mean that any default value
+;; mentioned in the formal arglist should be considered as implicitly
+;; quoted rather than evaluated. This is used in `cl-defsubst' when
+;; performing compiler-macro-expansion, since at that time the
+;; arguments hold expressions rather than values.
+;; - &cl-defs (DEF . DEFS): Gives the default value to use for missing
+;; optional arguments which don't have an explicit default value.
+;; DEFS is an alist mapping vars to their default default value.
+;; and DEF is the default default to use for all other vars.
+
+(defvar cl--bind-block) ;Name of surrounding block, only use for `signal' data.
+(defvar cl--bind-defs) ;(DEF . DEFS) giving the "default default" for optargs.
+(defvar cl--bind-enquote) ;Non-nil if &cl-quote was in the formal arglist!
+(defvar cl--bind-lets) (defvar cl--bind-forms)
(defun cl--transform-lambda (form bind-block)
"Transform a function form FORM of name BIND-BLOCK.
FORM is of the form (ARGS . BODY)."
(let* ((args (car form)) (body (cdr form)) (orig-args args)
(cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
- (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil)
- (header nil) (simple-args nil))
- (while (or (stringp (car body))
- (memq (car-safe (car body)) '(interactive declare cl-declare)))
- (push (pop body) header))
+ (parsed-body (macroexp-parse-body body))
+ (header (car parsed-body)) (simple-args nil))
+ (setq body (cdr parsed-body))
+ ;; "(. X) to (&rest X)" conversion already done in cl--do-arglist, but we
+ ;; do it here as well, so as to be able to see if we can avoid
+ ;; cl--do-arglist.
(setq args (if (listp args) (cl-copy-list args) (list '&rest args)))
(let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
- (if (setq cl--bind-defs (cadr (memq '&cl-defs args)))
- (setq args (delq '&cl-defs (delq cl--bind-defs args))
- cl--bind-defs (cadr cl--bind-defs)))
+ (let ((cl-defs (memq '&cl-defs args)))
+ (when cl-defs
+ (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))))
(if (setq cl--bind-enquote (memq '&cl-quote args))
(setq args (delq '&cl-quote args)))
(if (memq '&whole args) (error "&whole not currently implemented"))
- (let* ((p (memq '&environment args)) (v (cadr p))
- (env-exp 'macroexpand-all-environment))
+ (let* ((p (memq '&environment args))
+ (v (cadr p)))
(if p (setq args (nconc (delq (car p) (delq v args))
- (list '&aux (list v env-exp))))))
- (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))
+ `(&aux (,v macroexpand-all-environment))))))
+ ;; 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'.
+ (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))))
- (if (null args)
- (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body))
- (if (memq '&optional simple-args) (push '&optional args))
- (cl--do-arglist args nil (- (length simple-args)
- (if (memq '&optional simple-args) 1 0)))
- (setq cl--bind-lets (nreverse cl--bind-lets))
- (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval)
- ,@(nreverse cl--bind-inits)))
- (nconc (nreverse simple-args)
- (list '&rest (car (pop cl--bind-lets))))
- (nconc (let ((hdr (nreverse header)))
+ (let* ((cl--bind-lets nil) (cl--bind-forms nil)
+ (rest-args
+ (cond
+ ((null args) nil)
+ ((eq (car args) '&aux)
+ (cl--do-&aux args)
+ (setq cl--bind-lets (nreverse cl--bind-lets))
+ nil)
+ (t ;; `simple-args' doesn't handle all the parsing that we need,
+ ;; so we pass the rest to cl--do-arglist which will do
+ ;; "manual" parsing.
+ (let ((slen (length simple-args)))
+ (when (memq '&optional simple-args)
+ (cl-decf slen))
+ (setq header
;; Macro expansion can take place in the middle of
;; apparently harmless computation, so it should not
;; touch the match-data.
(save-match-data
(require 'help-fns)
(cons (help-add-fundoc-usage
- (if (stringp (car hdr)) (pop hdr))
+ (if (stringp (car header)) (pop header))
;; Be careful with make-symbol and (back)quote,
;; see bug#12884.
(let ((print-gensym nil) (print-quoted t))
(format "%S" (cons 'fn (cl--make-usage-args
orig-args)))))
- hdr)))
- (list `(let* ,cl--bind-lets
- ,@(nreverse cl--bind-forms)
- ,@body)))))))
+ header)))
+ ;; FIXME: we'd want to choose an arg name for the &rest param
+ ;; and pass that as `expr' to cl--do-arglist, but that ends up
+ ;; generating code with a redundant let-binding, so we instead
+ ;; pass a dummy and then look in cl--bind-lets to find what var
+ ;; this was bound to.
+ (cl--do-arglist args :dummy slen)
+ (setq cl--bind-lets (nreverse cl--bind-lets))
+ ;; (cl-assert (eq :dummy (nth 1 (car cl--bind-lets))))
+ (list '&rest (car (pop cl--bind-lets))))))))
+ `(nil
+ (,@(nreverse simple-args) ,@rest-args)
+ ,@header
+ ,(macroexp-let* cl--bind-lets
+ (macroexp-progn
+ `(,@(nreverse cl--bind-forms)
+ ,@body)))))))
;;;###autoload
(defmacro cl-defun (name args &rest body)
(form `(defun ,name ,@(cdr res))))
(if (car res) `(progn ,(car res) ,form) form)))
+;;;###autoload
+(defmacro cl-iter-defun (name args &rest body)
+ "Define NAME as a generator function.
+Like normal `iter-defun', except ARGLIST allows full Common Lisp conventions,
+and BODY is implicitly surrounded by (cl-block NAME ...).
+
+\(fn NAME ARGLIST [DOCSTRING] BODY...)"
+ (declare (debug
+ ;; Same as iter-defun but use cl-lambda-list.
+ (&define [&or name ("setf" :name setf name)]
+ cl-lambda-list
+ cl-declarations-or-string
+ [&optional ("interactive" interactive)]
+ def-body))
+ (doc-string 3)
+ (indent 2))
+ (require 'generator)
+ (let* ((res (cl--transform-lambda (cons args body) name))
+ (form `(iter-defun ,name ,@(cdr res))))
+ (if (car res) `(progn ,(car res) ,form) form)))
+
;; The lambda list for macros is different from that of normal lambdas.
;; Note that &environment is only allowed as first or last items in the
;; top level list.
(t x)))
(defun cl--make-usage-args (arglist)
+ (let ((aux (ignore-errors (cl-position '&aux arglist))))
+ (when aux
+ ;; `&aux' args aren't arguments, so let's just drop them from the
+ ;; usage info.
+ (setq arglist (cl-subseq arglist 0 aux))))
(if (cdr-safe (last arglist)) ;Not a proper list.
(let* ((last (last arglist))
(tail (cdr last)))
(setcdr last nil)
(nconc (cl--make-usage-args arglist) (cl--make-usage-var tail)))
(setcdr last tail)))
- ;; `orig-args' can contain &cl-defs (an internal
- ;; CL thingy I don't understand), so remove it.
+ ;; `orig-args' can contain &cl-defs.
(let ((x (memq '&cl-defs arglist)))
(when x (setq arglist (delq (car x) (remq (cadr x) arglist)))))
(let ((state nil))
))))
arglist))))
-(defun cl--do-arglist (args expr &optional num) ; uses bind-*
+(defun cl--do-&aux (args)
+ (while (and (eq (car args) '&aux) (pop args))
+ (while (and args (not (memq (car args) cl--lambda-list-keywords)))
+ (if (consp (car args))
+ (if (and cl--bind-enquote (cl-cadar args))
+ (cl--do-arglist (caar args)
+ `',(cadr (pop args)))
+ (cl--do-arglist (caar args) (cadr (pop args))))
+ (cl--do-arglist (pop args) nil))))
+ (if args (error "Malformed argument list ends with: %S" args)))
+
+(defun cl--do-arglist (args expr &optional num) ; uses cl--bind-*
(if (nlistp args)
(if (or (memq args cl--lambda-list-keywords) (not (symbolp args)))
(error "Invalid argument name: %s" args)
(let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
(let ((p (memq '&body args))) (if p (setcar p '&rest)))
(if (memq '&environment args) (error "&environment used incorrectly"))
- (let ((save-args args)
- (restarg (memq '&rest args))
+ (let ((restarg (memq '&rest args))
(safety (if (cl--compiling-file) cl--optimize-safety 3))
(keys nil)
(laterarg nil) (exactarg nil) minarg)
(or num (setq num 0))
- (if (listp (cadr restarg))
- (setq restarg (make-symbol "--cl-rest--"))
- (setq restarg (cadr restarg)))
+ (setq restarg (if (listp (cadr restarg))
+ (make-symbol "--cl-rest--")
+ (cadr restarg)))
(push (list restarg expr) cl--bind-lets)
(if (eq (car args) '&whole)
(push (list (cl--pop2 args) restarg) cl--bind-lets))
(intern (format ":%s" name)))))
(varg (if (consp (car arg)) (cl-cadar arg) (car arg)))
(def (if (cdr arg) (cadr arg)
- (or (car cl--bind-defs) (cadr (assq varg cl--bind-defs)))))
+ ;; The ordering between those two or clauses is
+ ;; irrelevant, since in practice only one of the two
+ ;; is ever non-nil (the car is only used for
+ ;; cl-deftype which doesn't use the cdr).
+ (or (car cl--bind-defs)
+ (cadr (assq varg cl--bind-defs)))))
(look `(plist-member ,restarg ',karg)))
(and def cl--bind-enquote (setq def `',def))
(if (cddr arg)
keys)
(car ,var)))))))
(push `(let ((,var ,restarg)) ,check) cl--bind-forms)))
- (while (and (eq (car args) '&aux) (pop args))
- (while (and args (not (memq (car args) cl--lambda-list-keywords)))
- (if (consp (car args))
- (if (and cl--bind-enquote (cl-cadar args))
- (cl--do-arglist (caar args)
- `',(cadr (pop args)))
- (cl--do-arglist (caar args) (cadr (pop args))))
- (cl--do-arglist (pop args) nil))))
- (if args (error "Malformed argument list %s" save-args)))))
+ (cl--do-&aux args)
+ nil)))
(defun cl--arglist-args (args)
(if (nlistp args) (list args)
"Bind the variables in ARGS to the result of EXPR and execute BODY."
(declare (indent 2)
(debug (&define cl-macro-list def-form cl-declarations def-body)))
- (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-inits nil)
+ (let* ((cl--bind-lets nil) (cl--bind-forms nil)
(cl--bind-defs nil) (cl--bind-block 'cl-none) (cl--bind-enquote nil))
(cl--do-arglist (or args '(&aux)) expr)
- (append '(progn) cl--bind-inits
- (list `(let* ,(nreverse cl--bind-lets)
- ,@(nreverse cl--bind-forms) ,@body)))))
+ (macroexp-let* (nreverse cl--bind-lets)
+ (macroexp-progn (append (nreverse cl--bind-forms) body)))))
;;; The `cl-eval-when' form.
Key values are compared by `eql'.
\n(fn EXPR (KEYLIST BODY...)...)"
(declare (indent 1) (debug (form &rest (sexp body))))
- (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
- (head-list nil)
- (body (cons
- 'cond
- (mapcar
- (function
- (lambda (c)
- (cons (cond ((memq (car c) '(t otherwise)) t)
- ((eq (car c) 'cl--ecase-error-flag)
- `(error "cl-ecase failed: %s, %s"
- ,temp ',(reverse head-list)))
- ((listp (car c))
- (setq head-list (append (car c) head-list))
- `(cl-member ,temp ',(car c)))
- (t
- (if (memq (car c) head-list)
- (error "Duplicate key in case: %s"
- (car c)))
- (push (car c) head-list)
- `(eql ,temp ',(car c))))
- (or (cdr c) '(nil)))))
- clauses))))
- (if (eq temp expr) body
- `(let ((,temp ,expr)) ,body))))
+ (macroexp-let2 macroexp-copyable-p temp expr
+ (let* ((head-list nil))
+ `(cond
+ ,@(mapcar
+ (lambda (c)
+ (cons (cond ((memq (car c) '(t otherwise)) t)
+ ((eq (car c) 'cl--ecase-error-flag)
+ `(error "cl-ecase failed: %s, %s"
+ ,temp ',(reverse head-list)))
+ ((listp (car c))
+ (setq head-list (append (car c) head-list))
+ `(cl-member ,temp ',(car c)))
+ (t
+ (if (memq (car c) head-list)
+ (error "Duplicate key in case: %s"
+ (car c)))
+ (push (car c) head-list)
+ `(eql ,temp ',(car c))))
+ (or (cdr c) '(nil))))
+ clauses)))))
;;;###autoload
(defmacro cl-ecase (expr &rest clauses)
\n(fn EXPR (TYPE BODY...)...)"
(declare (indent 1)
(debug (form &rest ([&or cl-type-spec "otherwise"] body))))
- (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
- (type-list nil)
- (body (cons
- 'cond
- (mapcar
- (function
- (lambda (c)
- (cons (cond ((eq (car c) 'otherwise) t)
- ((eq (car c) 'cl--ecase-error-flag)
- `(error "cl-etypecase failed: %s, %s"
- ,temp ',(reverse type-list)))
- (t
- (push (car c) type-list)
- (cl--make-type-test temp (car c))))
- (or (cdr c) '(nil)))))
- clauses))))
- (if (eq temp expr) body
- `(let ((,temp ,expr)) ,body))))
+ (macroexp-let2 macroexp-copyable-p temp expr
+ (let* ((type-list nil))
+ (cons
+ 'cond
+ (mapcar
+ (function
+ (lambda (c)
+ (cons (cond ((eq (car c) 'otherwise) t)
+ ((eq (car c) 'cl--ecase-error-flag)
+ `(error "cl-etypecase failed: %s, %s"
+ ,temp ',(reverse type-list)))
+ (t
+ (push (car c) type-list)
+ `(cl-typep ,temp ',(car c))))
+ (or (cdr c) '(nil)))))
+ clauses)))))
;;;###autoload
(defmacro cl-etypecase (expr &rest clauses)
(push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body)))
((memq word '(minimize minimizing maximize maximizing))
- (let* ((what (pop cl--loop-args))
- (temp (if (cl--simple-expr-p what) what
- (make-symbol "--cl-var--")))
- (var (cl--loop-handle-accum nil))
- (func (intern (substring (symbol-name word) 0 3)))
- (set `(setq ,var (if ,var (,func ,var ,temp) ,temp))))
- (push `(progn ,(if (eq temp what) set
- `(let ((,temp ,what)) ,set))
- t)
- cl--loop-body)))
+ (push `(progn ,(macroexp-let2 macroexp-copyable-p temp
+ (pop cl--loop-args)
+ (let* ((var (cl--loop-handle-accum nil))
+ (func (intern (substring (symbol-name word)
+ 0 3))))
+ `(setq ,var (if ,var (,func ,var ,temp) ,temp))))
+ t)
+ cl--loop-body))
((eq word 'with)
(let ((bindings nil))
(< cl--optimize-speed 3)
(= cl--optimize-safety 3)))
form
- (let* ((temp (if (cl--simple-expr-p form 3)
- form (make-symbol "--cl-var--")))
- (body `(progn (unless ,(cl--make-type-test temp type)
- (signal 'wrong-type-argument
- (list ',type ,temp ',form)))
- ,temp)))
- (if (eq temp form) body
- `(let ((,temp ,form)) ,body)))))
+ (macroexp-let2 macroexp-copyable-p temp form
+ `(progn (unless (cl-typep ,temp ',type)
+ (signal 'wrong-type-argument
+ (list ',type ,temp ',form)))
+ ,temp))))
(defvar cl--proclaim-history t) ; for future compilers
(defvar cl--declare-stack t) ; for future compilers
(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.
(tag (intern (format "cl-struct-%s" name)))
(tag-symbol (intern (format "cl-struct-%s-tags" name)))
(include-descs nil)
- (side-eff nil)
+ (include-name nil)
(type nil)
(named nil)
(forms nil)
+ (docstring (if (stringp (car descs)) (pop descs)))
pred-form pred-check)
- (if (stringp (car descs))
- (push `(put ',name 'structure-documentation
- ,(pop descs))
- forms))
(setq descs (cons '(cl-tag-slot)
(mapcar (function (lambda (x) (if (consp x) x (list x))))
descs)))
((eq opt :predicate)
(if args (setq predicate (car args))))
((eq opt :include)
- (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)
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)
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))
- (let ((incl include))
- (while incl
- (push `(cl-pushnew ',tag
- ,(intern (format "cl-struct-%s-tags" incl)))
- forms)
- (setq incl (get incl 'cl-struct-include)))))
+ 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))
(error "Invalid :type specifier: %s" type))
(if named (setq tag name)))
- (setq type 'vector named 'true)))
+ (setq named 'true)))
(or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
- (push `(defvar ,tag-symbol) forms)
(when (and (null predicate) named)
(setq predicate (intern (format "cl--struct-%s-p" name))))
(setq pred-form (and named
(let ((pos (- (length descs)
(length (memq (assq 'cl-tag-slot descs)
descs)))))
- (if (eq type 'vector)
- `(and (vectorp cl-x)
- (>= (length cl-x) ,(length descs))
- (memq (aref cl-x ,pos) ,tag-symbol))
- (if (= pos 0)
- `(memq (car-safe cl-x) ,tag-symbol)
- `(and (consp cl-x)
+ (cond
+ ((memq type '(nil 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))))))
pred-check (and pred-form (> safety 0)
(if (and (eq (cl-caadr pred-form) 'vectorp)
(push slot slots)
(push (nth 1 desc) defaults)
(push `(cl-defsubst ,accessor (cl-x)
+ (declare (side-effect-free t))
,@(and pred-check
(list `(or ,pred-check
- (error "%s accessing a non-%s"
- ',accessor ',name))))
- ,(if (eq type 'vector) `(aref cl-x ,pos)
+ (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))))
forms)
- (push (cons accessor t) side-eff)
(if (cadr (memq :read-only (cddr desc)))
(push `(gv-define-expander ,accessor
(lambda (_cl-do _cl-x)
defaults (nreverse defaults))
(when pred-form
(push `(cl-defsubst ,predicate (cl-x)
+ (declare (side-effect-free error-free))
,(if (eq (car pred-form) 'and)
(append pred-form '(t))
`(and ,pred-form t)))
forms)
- (push `(put ',name 'cl-deftype-satisfies ',predicate) forms)
- (push (cons predicate 'error-free) side-eff))
+ (push `(put ',name 'cl-deftype-satisfies ',predicate) forms))
(and copier
- (progn (push `(defun ,copier (x) (copy-sequence x)) forms)
- (push (cons copier t) side-eff)))
+ (push `(defalias ',copier #'copy-sequence) forms))
(if constructor
(push (list constructor
(cons '&key (delq nil (copy-sequence slots))))
(make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d)))
slots defaults)))
(push `(cl-defsubst ,name
- (&cl-defs '(nil ,@descs) ,@args)
- (,type ,@make))
- forms)
- (if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
- (push (cons name t) side-eff))))
+ (&cl-defs (nil ,@descs) ,@args)
+ ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
+ '((declare (side-effect-free t))))
+ (,(or type #'vector) ,@make))
+ forms)))
(if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
;; Don't bother adding to cl-custom-print-functions since it's not used
;; by anything anyway!
;; (and ,pred-form ,print-func))
;; cl-custom-print-functions))
;; forms))
- (push `(setq ,tag-symbol (list ',tag)) forms)
- (push `(cl-eval-when (compile load eval)
- (put ',name 'cl-struct-slots ',descs)
- (put ',name 'cl-struct-type ',(list type (eq named t)))
- (put ',name 'cl-struct-include ',include)
- (put ',name 'cl-struct-print ,print-auto)
- ,@(mapcar (lambda (x)
- `(function-put ',(car x) 'side-effect-free ',(cdr x)))
- side-eff))
- forms)
- `(progn ,@(nreverse (cons `',name forms)))))
+ `(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-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.
`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.
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)
(or (cdr (assq sym byte-compile-function-environment))
(cdr (assq sym byte-compile-macro-environment))))))
-(defun cl--make-type-test (val type)
- (pcase type
- ((and `(,name . ,args) (guard (get name 'cl-deftype-handler)))
- (cl--make-type-test val (apply (get name 'cl-deftype-handler)
- args)))
- (`(,(and name (or 'integer 'float 'real 'number))
- . ,(or `(,min ,max) pcase--dontcare))
- `(and ,(cl--make-type-test val name)
- ,(if (memq min '(* nil)) t
- (if (consp min) `(> ,val ,(car min))
- `(>= ,val ,min)))
- ,(if (memq max '(* nil)) t
- (if (consp max)
- `(< ,val ,(car max))
- `(<= ,val ,max)))))
- (`(,(and name (or 'and 'or 'not)) . ,args)
- (cons name (mapcar (lambda (x) (cl--make-type-test val x)) args)))
- (`(member . ,args)
- `(and (cl-member ,val ',args) t))
- (`(satisfies ,pred) `(funcall #',pred ,val))
- ((and (pred symbolp) (guard (get type 'cl-deftype-handler)))
- (cl--make-type-test val (funcall (get type 'cl-deftype-handler))))
- ((and (pred symbolp) (guard (get type 'cl-deftype-satisfies)))
- `(funcall #',(get type 'cl-deftype-satisfies) ,val))
- ((or 'nil 't) type)
- ('null `(null ,val))
- ('atom `(atom ,val))
- ('float `(floatp ,val))
- ('real `(numberp ,val))
- ('fixnum `(integerp ,val))
- ;; FIXME: Implement `base-char' and `extended-char'.
- ('character `(characterp ,val))
- ((pred symbolp)
- (let* ((name (symbol-name type))
- (namep (intern (concat name "p"))))
- (cond
- ((cl--macroexp-fboundp namep) (list namep val))
- ((cl--macroexp-fboundp
- (setq namep (intern (concat name "-p"))))
- (list namep val))
- ((cl--macroexp-fboundp type) (list type val))
- (t (error "Unknown type %S" type)))))
- (_ (error "Bad type spec: %s" type))))
-
-(defvar cl--object)
+(put 'null 'cl-deftype-satisfies #'null)
+(put 'atom 'cl-deftype-satisfies #'atom)
+(put 'real 'cl-deftype-satisfies #'numberp)
+(put 'fixnum 'cl-deftype-satisfies #'integerp)
+(put 'base-char 'cl-deftype-satisfies #'characterp)
+(put 'character 'cl-deftype-satisfies #'integerp)
+
+
;;;###autoload
-(defun cl-typep (object type) ; See compiler macro below.
- "Check that OBJECT is of type TYPE.
-TYPE is a Common Lisp-style type specifier."
- (declare (compiler-macro cl--compiler-macro-typep))
- (let ((cl--object object)) ;; Yuck!!
- (eval (cl--make-type-test 'cl--object type))))
-
-(defun cl--compiler-macro-typep (form val type)
- (if (macroexp-const-p type)
- (macroexp-let2 macroexp-copyable-p temp val
- (cl--make-type-test temp (cl--const-expr-val type)))
- form))
+(define-inline cl-typep (val type)
+ (inline-letevals (val)
+ (pcase (inline-const-val type)
+ ((and `(,name . ,args) (guard (get name 'cl-deftype-handler)))
+ (inline-quote
+ (cl-typep ,val ',(apply (get name 'cl-deftype-handler) args))))
+ (`(,(and name (or 'integer 'float 'real 'number))
+ . ,(or `(,min ,max) pcase--dontcare))
+ (inline-quote
+ (and (cl-typep ,val ',name)
+ ,(if (memq min '(* nil)) t
+ (if (consp min)
+ (inline-quote (> ,val ',(car min)))
+ (inline-quote (>= ,val ',min))))
+ ,(if (memq max '(* nil)) t
+ (if (consp max)
+ (inline-quote (< ,val ',(car max)))
+ (inline-quote (<= ,val ',max)))))))
+ (`(not ,type) (inline-quote (not (cl-typep ,val ',type))))
+ (`(,(and name (or 'and 'or)) . ,types)
+ (cond
+ ((null types) (inline-quote ',(eq name 'and)))
+ ((null (cdr types))
+ (inline-quote (cl-typep ,val ',(car types))))
+ (t
+ (let ((head (car types))
+ (rest `(,name . ,(cdr types))))
+ (cond
+ ((eq name 'and)
+ (inline-quote (and (cl-typep ,val ',head)
+ (cl-typep ,val ',rest))))
+ (t
+ (inline-quote (or (cl-typep ,val ',head)
+ (cl-typep ,val ',rest)))))))))
+ (`(eql ,v) (inline-quote (and (eql ,val ',v) t)))
+ (`(member . ,args) (inline-quote (and (memql ,val ',args) t)))
+ (`(satisfies ,pred) (inline-quote (funcall #',pred ,val)))
+ ((and (pred symbolp) type (guard (get type 'cl-deftype-handler)))
+ (inline-quote
+ (cl-typep ,val ',(funcall (get type 'cl-deftype-handler)))))
+ ((and (pred symbolp) type (guard (get type 'cl-deftype-satisfies)))
+ (inline-quote (funcall #',(get type 'cl-deftype-satisfies) ,val)))
+ ((and (or 'nil 't) type) (inline-quote ',type))
+ ((and (pred symbolp) type)
+ (let* ((name (symbol-name type))
+ (namep (intern (concat name "p"))))
+ (cond
+ ((cl--macroexp-fboundp namep) (inline-quote (funcall #',namep ,val)))
+ ((cl--macroexp-fboundp
+ (setq namep (intern (concat name "-p"))))
+ (inline-quote (funcall #',namep ,val)))
+ ((cl--macroexp-fboundp type) (inline-quote (funcall #',type ,val)))
+ (t (error "Unknown type %S" type)))))
+ (type (error "Bad type spec: %s" type)))))
+
;;;###autoload
(defmacro cl-check-type (form type &optional string)
(declare (debug (place cl-type-spec &optional stringp)))
(and (or (not (cl--compiling-file))
(< cl--optimize-speed 3) (= cl--optimize-safety 3))
- (let* ((temp (if (cl--simple-expr-p form 3)
- form (make-symbol "--cl-var--")))
- (body `(or ,(cl--make-type-test temp type)
- (signal 'wrong-type-argument
- (list ,(or string `',type)
- ,temp ',form)))))
- (if (eq temp form) `(progn ,body nil)
- `(let ((,temp ,form)) ,body nil)))))
+ (macroexp-let2 macroexp-copyable-p temp form
+ `(progn (or (cl-typep ,temp ',type)
+ (signal 'wrong-type-argument
+ (list ,(or string `',type) ,temp ',form)))
+ nil))))
;;;###autoload
(defmacro cl-assert (form &optional show-args string &rest args)
(cdr form))))))
`(progn
(or ,form
- ,(if string
- `(error ,string ,@sargs ,@args)
- `(signal 'cl-assertion-failed
- (list ',form ,@sargs))))
+ (cl--assertion-failed
+ ',form ,@(if (or string sargs args)
+ `(,string (list ,@sargs) (list ,@args)))))
nil))))
;;; Compiler macros.
(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)
(declare (debug cl-defmacro) (doc-string 3) (indent 2))
`(cl-eval-when (compile load eval)
(put ',name 'cl-deftype-handler
- (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body)))))
+ (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body)))))
+
+(cl-deftype extended-char () `(and character (not base-char)))
;;; Additional functions that we can now define because we've defined
;;; `cl-defsubst' and `cl-typep'.
-(cl-defsubst cl-struct-slot-value (struct-type slot-name inst)
- ;; The use of `cl-defsubst' here gives us both a compiler-macro
- ;; and a gv-expander "for free".
+(define-inline cl-struct-slot-value (struct-type slot-name inst)
"Return the value of slot SLOT-NAME in INST of STRUCT-TYPE.
STRUCT and SLOT-NAME are symbols. INST is a structure instance."
(declare (side-effect-free t))
- (unless (cl-typep inst struct-type)
- (signal 'wrong-type-argument (list struct-type inst)))
- ;; We could use `elt', but since the byte compiler will resolve the
- ;; branch below at compile time, it's more efficient to use the
- ;; type-specific accessor.
- (if (eq (cl-struct-sequence-type struct-type) 'vector)
- (aref inst (cl-struct-slot-offset struct-type slot-name))
- (nth (cl-struct-slot-offset struct-type slot-name) inst)))
+ (inline-letevals (struct-type slot-name inst)
+ (inline-quote
+ (progn
+ (unless (cl-typep ,inst ,struct-type)
+ (signal 'wrong-type-argument (list ,struct-type ,inst)))
+ ;; We could use `elt', but since the byte compiler will resolve the
+ ;; branch below at compile time, it's more efficient to use the
+ ;; type-specific accessor.
+ (if (eq (cl-struct-sequence-type ,struct-type) 'list)
+ (nth (cl-struct-slot-offset ,struct-type ,slot-name) ,inst)
+ (aref ,inst (cl-struct-slot-offset ,struct-type ,slot-name)))))))
(run-hooks 'cl-macs-load-hook)