src/code/parse-defmacro.lisp

   1 ;;;; the PARSE-DEFMACRO function and related code
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!KERNEL")
  13
  14 ;;; variables for accumulating the results of parsing a DEFMACRO. (Declarations
  15 ;;; in DEFMACRO are the reason this isn't as easy as it sounds.)
  16 (defvar *arg-tests*) ; tests that do argument counting at expansion time
  17 (declaim (type list *arg-tests*))
  18 (defvar *system-lets*) ; LET bindings done to allow lambda-list parsing
  19 (declaim (type list *system-lets*))
  20 (defvar *user-lets*) ; LET bindings that the user has explicitly supplied
  21 (declaim (type list *user-lets*))
  22 (defvar *env-var*) ; &ENVIRONMENT variable name
  23
  24 ;; the default default for unsupplied &OPTIONAL and &KEY args
  25 (defvar *default-default*)
  26
  27 ;;; temps that we introduce and might not reference
  28 (defvar *ignorable-vars*)
  29 (declaim (type list *ignorable-vars*))
  30
  31 ;;; Return, as multiple values, a body, possibly a DECLARE form to put
  32 ;;; where this code is inserted, the documentation for the parsed
  33 ;;; body, and bounds on the number of arguments.
  34 (defun parse-defmacro (lambda-list arg-list-name body name context
  35                                    &key
  36                                    (anonymousp nil)
  37                                    (doc-string-allowed t)
  38                                    ((:environment env-arg-name))
  39                                    ((:default-default *default-default*))
  40                                    (error-fun 'error)
  41                                    (wrap-block t))
  42   (multiple-value-bind (forms declarations documentation)
  43       (parse-body body :doc-string-allowed doc-string-allowed)
  44     (let ((*arg-tests* ())
  45           (*user-lets* ())
  46           (*system-lets* ())
  47           (*ignorable-vars* ())
  48           (*env-var* nil))
  49       (multiple-value-bind (env-arg-used minimum maximum)
  50           (parse-defmacro-lambda-list lambda-list arg-list-name name
  51                                       context error-fun (not anonymousp)
  52                                       nil)
  53         (values `(let* (,@(when env-arg-used
  54                             `((,*env-var* ,env-arg-name)))
  55                         ,@(nreverse *system-lets*))
  56                    ,@(when *ignorable-vars*
  57                        `((declare (ignorable ,@*ignorable-vars*))))
  58                    ,@*arg-tests*
  59                    (let* ,(nreverse *user-lets*)
  60                      ,@declarations
  61                      ,@(if wrap-block
  62                            `((block ,(fun-name-block-name name)
  63                                ,@forms))
  64                            forms)))
  65                 `(,@(when (and env-arg-name (not env-arg-used))
  66                       `((declare (ignore ,env-arg-name)))))
  67                 documentation
  68                 minimum
  69                 maximum)))))
  70
  71 ;;; partial reverse-engineered documentation:
  72 ;;;   TOPLEVEL is true for calls through PARSE-DEFMACRO from DEFSETF and
  73 ;;;     DESTRUCTURING-BIND, false otherwise.
  74 ;;; -- WHN 19990620
  75 (defun parse-defmacro-lambda-list (possibly-dotted-lambda-list
  76                                    arg-list-name
  77                                    name
  78                                    context
  79                                    error-fun
  80                                    &optional
  81                                    toplevel
  82                                    env-illegal)
  83   (let* (;; PATH is a sort of pointer into the part of the lambda list we're
  84          ;; considering at this point in the code. PATH-0 is the root of the
  85          ;; lambda list, which is the initial value of PATH.
  86          (path-0 (if toplevel
  87                      `(cdr ,arg-list-name)
  88                      arg-list-name))
  89          (path path-0) ; (will change below)
  90          (now-processing :required)
  91          (maximum 0)
  92          (minimum 0)
  93          (keys ())
  94          (key-seen nil)
  95          (aux-seen nil)
  96          (optional-seen nil)
  97          ;; ANSI specifies that dotted lists are "treated exactly as if the
  98          ;; parameter name that ends the list had appeared preceded by &rest."
  99          ;; We force this behavior by transforming dotted lists into ordinary
 100          ;; lists with explicit &REST elements.
 101          (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll))
 102                            (reversed-result nil))
 103                           ((atom in-pdll)
 104                            (nreverse (if in-pdll
 105                                          (list* in-pdll '&rest reversed-result)
 106                                          reversed-result)))
 107                         (push (car in-pdll) reversed-result)))
 108          rest-name restp allow-other-keys-p env-arg-used)
 109     (when (member '&whole (rest lambda-list))
 110       (error "&WHOLE may only appear first in ~S lambda-list." context))
 111     (do ((rest-of-args lambda-list (cdr rest-of-args)))
 112         ((null rest-of-args))
 113       (macrolet ((process-sublist (var sublist-name path)
 114                    (once-only ((var var))
 115                      `(if (listp ,var)
 116                           (let ((sub-list-name (gensym ,sublist-name)))
 117                             (push-sub-list-binding sub-list-name ,path ,var
 118                                                    name context error-fun)
 119                             (parse-defmacro-lambda-list ,var sub-list-name name
 120                                                         context error-fun))
 121                           (push-let-binding ,var ,path nil))))
 122                  (normalize-singleton (var)
 123                    `(when (null (cdr ,var))
 124                      (setf (cdr ,var) (list *default-default*)))))
 125         (let ((var (car rest-of-args)))
 126           (typecase var
 127             (list
 128              (case now-processing
 129                ((:required)
 130                 (when restp
 131                   (defmacro-error (format nil "required argument after ~A" restp)
 132                       context name))
 133                 (process-sublist var "SUBLIST-" `(car ,path))
 134                 (setq path `(cdr ,path)
 135                       minimum (1+ minimum)
 136                       maximum (1+ maximum)))
 137                ((:optionals)
 138                 (normalize-singleton var)
 139                 (destructuring-bind (varname &optional initform supplied-p)
 140                     var
 141                   (push-optional-binding varname initform supplied-p
 142                                          `(not (null ,path)) `(car ,path)
 143                                          name context error-fun))
 144                 (setq path `(cdr ,path)
 145                       maximum (1+ maximum)))
 146                ((:keywords)
 147                 (normalize-singleton var)
 148                 (let* ((keyword-given (consp (car var)))
 149                        (variable (if keyword-given
 150                                      (cadar var)
 151                                      (car var)))
 152                        (keyword (if keyword-given
 153                                     (caar var)
 154                                     (keywordicate variable)))
 155                        (supplied-p (caddr var)))
 156                   (push-optional-binding variable (cadr var) supplied-p
 157                                          `(keyword-supplied-p ',keyword
 158                                                               ,rest-name)
 159                                          `(lookup-keyword ',keyword
 160                                                           ,rest-name)
 161                                          name context error-fun)
 162                   (push keyword keys)))
 163                ((:auxs)
 164                 (push-let-binding (car var) (cadr var) nil))))
 165             ((and symbol (not (eql nil)))
 166              (case var
 167                (&whole
 168                 (cond ((cdr rest-of-args)
 169                        (setq rest-of-args (cdr rest-of-args))
 170                        ;; Special case for compiler-macros: if car of
 171                        ;; the form is FUNCALL skip over it for
 172                        ;; destructuring, pretending cdr of the form is
 173                        ;; the actual form.
 174                        (when (eq context 'define-compiler-macro)
 175                          (push-let-binding
 176                           arg-list-name
 177                           arg-list-name
 178                           t
 179                           `(not (and (listp ,arg-list-name)
 180                                      (eq 'funcall (car ,arg-list-name))))
 181                           `(setf ,arg-list-name (cdr ,arg-list-name))))
 182                        (process-sublist (car rest-of-args)
 183                                         "WHOLE-LIST-" arg-list-name))
 184                       (t
 185                        (defmacro-error "&WHOLE" context name))))
 186                (&environment
 187                 (cond (env-illegal
 188                        (error "&ENVIRONMENT is not valid with ~S." context))
 189                       ((not toplevel)
 190                        (error "&ENVIRONMENT is only valid at top level of ~
 191                              lambda-list."))
 192                       (env-arg-used
 193                        (error "Repeated &ENVIRONMENT.")))
 194                 (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
 195                        (setq rest-of-args (cdr rest-of-args))
 196                        (check-defmacro-arg (car rest-of-args))
 197                        (setq *env-var* (car rest-of-args)
 198                              env-arg-used t))
 199                       (t
 200                        (defmacro-error "&ENVIRONMENT" context name))))
 201                ((&rest &body)
 202                 (cond ((or key-seen aux-seen)
 203                        (error "~A after ~A in ~A" var (or key-seen aux-seen) context))
 204                       ((and (not restp) (cdr rest-of-args))
 205                        (setq rest-of-args (cdr rest-of-args)
 206                              restp var)
 207                        (process-sublist (car rest-of-args) "REST-LIST-" path))
 208                       (t
 209                        (defmacro-error (symbol-name var) context name))))
 210                (&optional
 211                 (when (or key-seen aux-seen restp)
 212                   (error "~A after ~A in ~A lambda-list." var (or key-seen aux-seen restp) context))
 213                 (when optional-seen
 214                   (error "Multiple ~A in ~A lambda list." var context))
 215                 (setq now-processing :optionals
 216                       optional-seen var))
 217                (&key
 218                 (when aux-seen
 219                   (error "~A after ~A in ~A lambda-list." '&key '&aux context))
 220                 (when key-seen
 221                   (error "Multiple ~A in ~A lambda-list." '&key context))
 222                 (setf now-processing :keywords
 223                       rest-name (gensym "KEYWORDS-")
 224                       restp var
 225                       key-seen var)
 226                 (push rest-name *ignorable-vars*)
 227                 (push-let-binding rest-name path t))
 228                (&allow-other-keys
 229                 (unless (eq now-processing :keywords)
 230                   (error "~A outside ~A section of lambda-list in ~A." var '&key context))
 231                 (when allow-other-keys-p
 232                   (error "Multiple ~A in ~A lambda-list." var context))
 233                 (setq allow-other-keys-p t))
 234                (&aux
 235                 (when aux-seen
 236                   (error "Multiple ~A in ~A lambda-list." '&aux context))
 237                 (setq now-processing :auxs
 238                       aux-seen var))
 239                ;; FIXME: Other lambda list keywords.
 240                (t
 241                 (case now-processing
 242                   ((:required)
 243                    (when restp
 244                      (defmacro-error (format nil "required argument after ~A" restp)
 245                          context name))
 246                    (push-let-binding var `(car ,path) nil)
 247                    (setq minimum (1+ minimum)
 248                          maximum (1+ maximum)
 249                          path `(cdr ,path)))
 250                   ((:optionals)
 251                    (push-let-binding var `(car ,path) nil `(not (null ,path)))
 252                    (setq path `(cdr ,path)
 253                          maximum (1+ maximum)))
 254                   ((:keywords)
 255                    (let ((key (keywordicate var)))
 256                      (push-let-binding
 257                       var
 258                       `(lookup-keyword ,key ,rest-name)
 259                       nil
 260                       `(keyword-supplied-p ,key ,rest-name))
 261                      (push key keys)))
 262                   ((:auxs)
 263                    (push-let-binding var nil nil))))))
 264             (t
 265              (error "non-symbol in lambda-list: ~S" var))))))
 266     (let (;; common subexpression, suitable for passing to functions
 267           ;; which expect a MAXIMUM argument regardless of whether
 268           ;; there actually is a maximum number of arguments
 269           ;; (expecting MAXIMUM=NIL when there is no maximum)
 270           (explicit-maximum (and (not restp) maximum)))
 271       (unless (and restp (zerop minimum))
 272         (push `(unless ,(if restp
 273                             ;; (If RESTP, then the argument list might be
 274                             ;; dotted, in which case ordinary LENGTH won't
 275                             ;; work.)
 276                             `(list-of-length-at-least-p ,path-0 ,minimum)
 277                             `(proper-list-of-length-p ,path-0 ,minimum ,maximum))
 278                  ,(if (eq error-fun 'error)
 279                       `(arg-count-error ',context ',name ,path-0
 280                                         ',lambda-list ,minimum
 281                                         ,explicit-maximum)
 282                       `(,error-fun 'arg-count-error
 283                                    :kind ',context
 284                                    ,@(when name `(:name ',name))
 285                                    :args ,path-0
 286                                    :lambda-list ',lambda-list
 287                                    :minimum ,minimum
 288                                    :maximum ,explicit-maximum)))
 289               *arg-tests*))
 290       (when key-seen
 291         (let ((problem (gensym "KEY-PROBLEM-"))
 292               (info (gensym "INFO-")))
 293           (push `(multiple-value-bind (,problem ,info)
 294                      (verify-keywords ,rest-name
 295                                       ',keys
 296                                       ',allow-other-keys-p)
 297                    (when ,problem
 298                      (,error-fun
 299                       'defmacro-lambda-list-broken-key-list-error
 300                       :kind ',context
 301                       ,@(when name `(:name ',name))
 302                       :problem ,problem
 303                       :info ,info)))
 304                 *arg-tests*)))
 305       (values env-arg-used minimum explicit-maximum))))
 306
 307 ;;; We save space in macro definitions by calling this function.
 308 (defun arg-count-error (context name args lambda-list minimum maximum)
 309   (let (#-sb-xc-host
 310         (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
 311     (error 'arg-count-error
 312            :kind context
 313            :name name
 314            :args args
 315            :lambda-list lambda-list
 316            :minimum minimum
 317            :maximum maximum)))
 318
 319 (defun push-sub-list-binding (variable path object name context error-fun)
 320   (check-defmacro-arg variable)
 321   (let ((var (gensym "TEMP-")))
 322     (push `(,variable
 323             (let ((,var ,path))
 324               (if (listp ,var)
 325                 ,var
 326                 (,error-fun 'defmacro-bogus-sublist-error
 327                             :kind ',context
 328                             ,@(when name `(:name ',name))
 329                             :object ,var
 330                             :lambda-list ',object))))
 331           *system-lets*)))
 332
 333 (defun push-let-binding (variable path systemp &optional condition
 334                                   (init-form *default-default*))
 335   (check-defmacro-arg variable)
 336   (let ((let-form (if condition
 337                       `(,variable (if ,condition ,path ,init-form))
 338                       `(,variable ,path))))
 339     (if systemp
 340       (push let-form *system-lets*)
 341       (push let-form *user-lets*))))
 342
 343 (defun push-optional-binding (value-var init-form supplied-var condition path
 344                                         name context error-fun)
 345   (unless supplied-var
 346     (setq supplied-var (gensym "SUPPLIEDP-")))
 347   (push-let-binding supplied-var condition t)
 348   (cond ((consp value-var)
 349          (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
 350            (push-sub-list-binding whole-thing
 351                                   `(if ,supplied-var ,path ,init-form)
 352                                   value-var name context error-fun)
 353            (parse-defmacro-lambda-list value-var whole-thing name
 354                                        context error-fun)))
 355         ((symbolp value-var)
 356          (push-let-binding value-var path nil supplied-var init-form))
 357         (t
 358          (error "illegal optional variable name: ~S" value-var))))
 359
 360 (defun defmacro-error (problem context name)
 361   (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]"
 362          problem context name))
 363
 364 (defun check-defmacro-arg (arg)
 365   (when (or (and *env-var* (eq arg *env-var*))
 366             (member arg *system-lets* :key #'car)
 367             (member arg *user-lets* :key #'car))
 368     (error "variable ~S occurs more than once" arg)))
 369
 370 ;;; Determine whether KEY-LIST is a valid list of keyword/value pairs.
 371 ;;; Do not signal the error directly, 'cause we don't know how it
 372 ;;; should be signaled.
 373 (defun verify-keywords (key-list valid-keys allow-other-keys)
 374   (do ((already-processed nil)
 375        (unknown-keyword nil)
 376        (remaining key-list (cddr remaining)))
 377       ((null remaining)
 378        (if (and unknown-keyword
 379                 (not allow-other-keys)
 380                 (not (lookup-keyword :allow-other-keys key-list)))
 381            (values :unknown-keyword (list unknown-keyword valid-keys))
 382            (values nil nil)))
 383     (cond ((not (and (consp remaining) (listp (cdr remaining))))
 384            (return (values :dotted-list key-list)))
 385           ((null (cdr remaining))
 386            (return (values :odd-length key-list)))
 387           ((or (eq (car remaining) :allow-other-keys)
 388                (member (car remaining) valid-keys))
 389            (push (car remaining) already-processed))
 390           (t
 391            (setq unknown-keyword (car remaining))))))
 392
 393 (defun lookup-keyword (keyword key-list)
 394   (do ((remaining key-list (cddr remaining)))
 395       ((endp remaining))
 396     (when (eq keyword (car remaining))
 397       (return (cadr remaining)))))
 398
 399 (defun keyword-supplied-p (keyword key-list)
 400   (do ((remaining key-list (cddr remaining)))
 401       ((endp remaining))
 402     (when (eq keyword (car remaining))
 403       (return t))))