X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fparse-defmacro.lisp;h=d9fc8532430c75cd00f88c0becad398632b701c9;hb=402958f92506b9d3de852601b8c1ccb99b5ee558;hp=b783de5d70fbf1fa9b7f98c801aa144535c1c84a;hpb=9f684145a95d4abbde75422edb8b217dfad3375b;p=sbcl.git diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index b783de5..d9fc853 100644 --- a/src/code/parse-defmacro.lisp +++ b/src/code/parse-defmacro.lisp @@ -32,84 +32,84 @@ ;;; where this code is inserted, the documentation for the parsed ;;; body, and bounds on the number of arguments. (defun parse-defmacro (lambda-list arg-list-name body name context - &key - (anonymousp nil) - (doc-string-allowed t) - ((:environment env-arg-name)) - ((:default-default *default-default*)) - (error-fun 'error) + &key + (anonymousp nil) + (doc-string-allowed t) + ((:environment env-arg-name)) + ((:default-default *default-default*)) + (error-fun 'error) (wrap-block t)) (multiple-value-bind (forms declarations documentation) (parse-body body :doc-string-allowed doc-string-allowed) (let ((*arg-tests* ()) - (*user-lets* ()) - (*system-lets* ()) - (*ignorable-vars* ()) + (*user-lets* ()) + (*system-lets* ()) + (*ignorable-vars* ()) (*env-var* nil)) (multiple-value-bind (env-arg-used minimum maximum) - (parse-defmacro-lambda-list lambda-list arg-list-name name - context error-fun (not anonymousp) - nil) - (values `(let* (,@(when env-arg-used + (parse-defmacro-lambda-list lambda-list arg-list-name name + context error-fun (not anonymousp) + nil) + (values `(let* (,@(when env-arg-used `((,*env-var* ,env-arg-name))) ,@(nreverse *system-lets*)) - ,@(when *ignorable-vars* - `((declare (ignorable ,@*ignorable-vars*)))) - ,@*arg-tests* - (let* ,(nreverse *user-lets*) - ,@declarations + ,@(when *ignorable-vars* + `((declare (ignorable ,@*ignorable-vars*)))) + ,@*arg-tests* + (let* ,(nreverse *user-lets*) + ,@declarations ,@(if wrap-block `((block ,(fun-name-block-name name) ,@forms)) forms))) - `(,@(when (and env-arg-name (not env-arg-used)) + `(,@(when (and env-arg-name (not env-arg-used)) `((declare (ignore ,env-arg-name))))) - documentation - minimum - maximum))))) + documentation + minimum + maximum))))) ;;; partial reverse-engineered documentation: ;;; TOPLEVEL is true for calls through PARSE-DEFMACRO from DEFSETF and ;;; DESTRUCTURING-BIND, false otherwise. ;;; -- WHN 19990620 (defun parse-defmacro-lambda-list (possibly-dotted-lambda-list - arg-list-name - name - context - error-fun - &optional - toplevel - env-illegal) + arg-list-name + name + context + error-fun + &optional + toplevel + env-illegal) (let* (;; PATH is a sort of pointer into the part of the lambda list we're - ;; considering at this point in the code. PATH-0 is the root of the - ;; lambda list, which is the initial value of PATH. - (path-0 (if toplevel + ;; considering at this point in the code. PATH-0 is the root of the + ;; lambda list, which is the initial value of PATH. + (path-0 (if toplevel `(cdr ,arg-list-name) arg-list-name)) - (path path-0) ; (will change below) - (now-processing :required) - (maximum 0) - (minimum 0) - (keys ()) - (key-seen nil) + (path path-0) ; (will change below) + (now-processing :required) + (maximum 0) + (minimum 0) + (keys ()) + (key-seen nil) (aux-seen nil) (optional-seen nil) - ;; ANSI specifies that dotted lists are "treated exactly as if the - ;; parameter name that ends the list had appeared preceded by &rest." - ;; We force this behavior by transforming dotted lists into ordinary - ;; lists with explicit &REST elements. - (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll)) - (reversed-result nil)) - ((atom in-pdll) - (nreverse (if in-pdll + ;; ANSI specifies that dotted lists are "treated exactly as if the + ;; parameter name that ends the list had appeared preceded by &rest." + ;; We force this behavior by transforming dotted lists into ordinary + ;; lists with explicit &REST elements. + (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll)) + (reversed-result nil)) + ((atom in-pdll) + (nreverse (if in-pdll (list* in-pdll '&rest reversed-result) reversed-result))) - (push (car in-pdll) reversed-result))) - rest-name restp allow-other-keys-p env-arg-used) + (push (car in-pdll) reversed-result))) + rest-name restp allow-other-keys-p env-arg-used) (when (member '&whole (rest lambda-list)) (error "&WHOLE may only appear first in ~S lambda-list." context)) (do ((rest-of-args lambda-list (cdr rest-of-args))) - ((null rest-of-args)) + ((null rest-of-args)) (macrolet ((process-sublist (var sublist-name path) (once-only ((var var)) `(if (listp ,var) @@ -119,9 +119,9 @@ (parse-defmacro-lambda-list ,var sub-list-name name context error-fun)) (push-let-binding ,var ,path nil)))) - (normalize-singleton (var) - `(when (null (cdr ,var)) - (setf (cdr ,var) (list *default-default*))))) + (normalize-singleton (var) + `(when (null (cdr ,var)) + (setf (cdr ,var) (list *default-default*))))) (let ((var (car rest-of-args))) (typecase var (list @@ -135,7 +135,7 @@ minimum (1+ minimum) maximum (1+ maximum))) ((:optionals) - (normalize-singleton var) + (normalize-singleton var) (destructuring-bind (varname &optional initform supplied-p) var (push-optional-binding varname initform supplied-p @@ -144,7 +144,7 @@ (setq path `(cdr ,path) maximum (1+ maximum))) ((:keywords) - (normalize-singleton var) + (normalize-singleton var) (let* ((keyword-given (consp (car var))) (variable (if keyword-given (cadar var) @@ -167,18 +167,18 @@ (&whole (cond ((cdr rest-of-args) (setq rest-of-args (cdr rest-of-args)) - ;; Special case for compiler-macros: if car of - ;; the form is FUNCALL skip over it for - ;; destructuring, pretending cdr of the form is - ;; the actual form. - (when (eq context 'define-compiler-macro) - (push-let-binding - arg-list-name - arg-list-name - t - `(not (and (listp ,arg-list-name) - (eq 'funcall (car ,arg-list-name)))) - `(setf ,arg-list-name (cdr ,arg-list-name)))) + ;; Special case for compiler-macros: if car of + ;; the form is FUNCALL skip over it for + ;; destructuring, pretending cdr of the form is + ;; the actual form. + (when (eq context 'define-compiler-macro) + (push-let-binding + arg-list-name + arg-list-name + t + `(not (and (listp ,arg-list-name) + (eq 'funcall (car ,arg-list-name)))) + `(setf ,arg-list-name (cdr ,arg-list-name)))) (process-sublist (car rest-of-args) "WHOLE-LIST-" arg-list-name)) (t @@ -254,20 +254,20 @@ ((:keywords) (let ((key (keywordicate var))) (push-let-binding - var - `(lookup-keyword ,key ,rest-name) - nil - `(keyword-supplied-p ,key ,rest-name)) + var + `(lookup-keyword ,key ,rest-name) + nil + `(keyword-supplied-p ,key ,rest-name)) (push key keys))) ((:auxs) (push-let-binding var nil nil)))))) (t (error "non-symbol in lambda-list: ~S" var)))))) (let (;; common subexpression, suitable for passing to functions - ;; which expect a MAXIMUM argument regardless of whether - ;; there actually is a maximum number of arguments - ;; (expecting MAXIMUM=NIL when there is no maximum) - (explicit-maximum (and (not restp) maximum))) + ;; which expect a MAXIMUM argument regardless of whether + ;; there actually is a maximum number of arguments + ;; (expecting MAXIMUM=NIL when there is no maximum) + (explicit-maximum (and (not restp) maximum))) (unless (and restp (zerop minimum)) (push `(unless ,(if restp ;; (If RESTP, then the argument list might be @@ -288,78 +288,78 @@ :maximum ,explicit-maximum))) *arg-tests*)) (when key-seen - (let ((problem (gensym "KEY-PROBLEM-")) - (info (gensym "INFO-"))) - (push `(multiple-value-bind (,problem ,info) - (verify-keywords ,rest-name - ',keys - ',allow-other-keys-p) - (when ,problem - (,error-fun - 'defmacro-lambda-list-broken-key-list-error - :kind ',context - ,@(when name `(:name ',name)) - :problem ,problem - :info ,info))) - *arg-tests*))) + (let ((problem (gensym "KEY-PROBLEM-")) + (info (gensym "INFO-"))) + (push `(multiple-value-bind (,problem ,info) + (verify-keywords ,rest-name + ',keys + ',allow-other-keys-p) + (when ,problem + (,error-fun + 'defmacro-lambda-list-broken-key-list-error + :kind ',context + ,@(when name `(:name ',name)) + :problem ,problem + :info ,info))) + *arg-tests*))) (values env-arg-used minimum explicit-maximum)))) ;;; We save space in macro definitions by calling this function. (defun arg-count-error (context name args lambda-list minimum maximum) (let (#-sb-xc-host - (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) + (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) (error 'arg-count-error - :kind context - :name name - :args args - :lambda-list lambda-list - :minimum minimum - :maximum maximum))) + :kind context + :name name + :args args + :lambda-list lambda-list + :minimum minimum + :maximum maximum))) (defun push-sub-list-binding (variable path object name context error-fun) (check-defmacro-arg variable) (let ((var (gensym "TEMP-"))) (push `(,variable - (let ((,var ,path)) - (if (listp ,var) - ,var - (,error-fun 'defmacro-bogus-sublist-error - :kind ',context - ,@(when name `(:name ',name)) - :object ,var - :lambda-list ',object)))) - *system-lets*))) + (let ((,var ,path)) + (if (listp ,var) + ,var + (,error-fun 'defmacro-bogus-sublist-error + :kind ',context + ,@(when name `(:name ',name)) + :object ,var + :lambda-list ',object)))) + *system-lets*))) (defun push-let-binding (variable path systemp &optional condition - (init-form *default-default*)) + (init-form *default-default*)) (check-defmacro-arg variable) (let ((let-form (if condition - `(,variable (if ,condition ,path ,init-form)) - `(,variable ,path)))) + `(,variable (if ,condition ,path ,init-form)) + `(,variable ,path)))) (if systemp (push let-form *system-lets*) (push let-form *user-lets*)))) (defun push-optional-binding (value-var init-form supplied-var condition path - name context error-fun) + name context error-fun) (unless supplied-var (setq supplied-var (gensym "SUPPLIEDP-"))) (push-let-binding supplied-var condition t) (cond ((consp value-var) - (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) - (push-sub-list-binding whole-thing - `(if ,supplied-var ,path ,init-form) - value-var name context error-fun) - (parse-defmacro-lambda-list value-var whole-thing name - context error-fun))) - ((symbolp value-var) - (push-let-binding value-var path nil supplied-var init-form)) - (t - (error "illegal optional variable name: ~S" value-var)))) + (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) + (push-sub-list-binding whole-thing + `(if ,supplied-var ,path ,init-form) + value-var name context error-fun) + (parse-defmacro-lambda-list value-var whole-thing name + context error-fun))) + ((symbolp value-var) + (push-let-binding value-var path nil supplied-var init-form)) + (t + (error "illegal optional variable name: ~S" value-var)))) (defun defmacro-error (problem context name) (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]" - problem context name)) + problem context name)) (defun check-defmacro-arg (arg) (when (or (and *env-var* (eq arg *env-var*)) @@ -376,19 +376,19 @@ (remaining key-list (cddr remaining))) ((null remaining) (if (and unknown-keyword - (not allow-other-keys) - (not (lookup-keyword :allow-other-keys key-list))) - (values :unknown-keyword (list unknown-keyword valid-keys)) - (values nil nil))) + (not allow-other-keys) + (not (lookup-keyword :allow-other-keys key-list))) + (values :unknown-keyword (list unknown-keyword valid-keys)) + (values nil nil))) (cond ((not (and (consp remaining) (listp (cdr remaining)))) - (return (values :dotted-list key-list))) - ((null (cdr remaining)) - (return (values :odd-length key-list))) - ((or (eq (car remaining) :allow-other-keys) - (member (car remaining) valid-keys)) - (push (car remaining) already-processed)) - (t - (setq unknown-keyword (car remaining)))))) + (return (values :dotted-list key-list))) + ((null (cdr remaining)) + (return (values :odd-length key-list))) + ((or (eq (car remaining) :allow-other-keys) + (member (car remaining) valid-keys)) + (push (car remaining) already-processed)) + (t + (setq unknown-keyword (car remaining)))))) (defun lookup-keyword (keyword key-list) (do ((remaining key-list (cddr remaining)))