0.9.2.43:
[sbcl.git] / src / code / parse-defmacro.lisp
index b783de5..d9fc853 100644 (file)
 ;;; 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)
                             (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
                       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
                 (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)
                (&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
                   ((: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
                                    :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*))
        (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)))