(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)
+;; 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)
and which will be used for the name of the `cl-block' surrounding the
function's body.
FORM is of the form (ARGS . BODY)."
- ;; FIXME: (lambda (a &aux b) 1) expands to (lambda (a &rest --cl-rest--) ...)
- ;; where the --cl-rest-- is clearly undesired.
(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-lets nil) (cl--bind-forms nil)
(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))
+ ;; 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))))
(if (setq cl--bind-enquote (memq '&cl-quote args))
(setq args (delq '&cl-quote args)))
(if (memq '&whole args) (error "&whole not currently implemented"))
(v (cadr p)))
(if p (setq args (nconc (delq (car p) (delq v 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'.
(while (and args (symbolp (car args))
(not (memq (car args) '(nil &rest &body &key &aux)))
(not (and (eq (car args) '&optional)
(push (pop args) 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 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* nil
- (nconc (nreverse simple-args)
- (list '&rest (car (pop cl--bind-lets))))
- (nconc (save-match-data ;; Macro expansion can take place in the
- ;; middle of apparently harmless computation, so it
- ;; should not touch the match-data.
- (require 'help-fns)
- (cons (help-add-fundoc-usage
- (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)))))
- header))
- (list `(let* ,cl--bind-lets
- ,@(nreverse cl--bind-forms)
- ,@body)))))))
+ (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)
+ (push '&optional 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 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)))))
+ 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)
(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-&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)))
(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)
(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)
(make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d)))
slots defaults)))
(push `(cl-defsubst ,name
- (&cl-defs '(nil ,@descs) ,@args)
+ (&cl-defs (nil ,@descs) ,@args)
,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
'((declare (side-effect-free t))))
(,(or type #'vector) ,@make))
(t
(inline-quote (or (cl-typep ,val ',head)
(cl-typep ,val ',rest)))))))))
- (`(member . ,args)
- (inline-quote (and (memql ,val ',args) t)))
+ (`(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
(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)))