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 whole-var 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   (unless (listp lambda-list)
  43     (bad-type lambda-list 'list "~S lambda-list is not a list: ~S"
  44               context lambda-list))
  45   (multiple-value-bind (forms declarations documentation)
  46       (parse-body body :doc-string-allowed doc-string-allowed)
  47     (let ((*arg-tests* ())
  48           (*user-lets* ())
  49           (*system-lets* ())
  50           (*ignorable-vars* ())
  51           (*env-var* nil))
  52       (multiple-value-bind (env-arg-used minimum maximum)
  53           (parse-defmacro-lambda-list lambda-list whole-var name context
  54                                       :error-fun error-fun
  55                                       :anonymousp anonymousp)
  56         (values `(let* (,@(nreverse *system-lets*))
  57                    #-sb-xc-host
  58                    (declare (muffle-conditions sb!ext:code-deletion-note))
  59                    ,@(when *ignorable-vars*
  60                        `((declare (ignorable ,@*ignorable-vars*))))
  61                    ,@*arg-tests*
  62                    (let* (,@(when env-arg-used
  63                             `((,*env-var* ,env-arg-name)))
  64                           ,@(nreverse *user-lets*))
  65                      ,@declarations
  66                      ,@(if wrap-block
  67                            `((block ,(fun-name-block-name name)
  68                                ,@forms))
  69                            forms)))
  70                 `(,@(when (and env-arg-name (not env-arg-used))
  71                       `((declare (ignore ,env-arg-name)))))
  72                 documentation
  73                 minimum
  74                 maximum)))))
  75
  76 (defun parse-defmacro-lambda-list (possibly-dotted-lambda-list
  77                                    whole-var
  78                                    name
  79                                    context
  80                                    &key
  81                                    error-fun
  82                                    anonymousp
  83                                    env-illegal
  84                                    sublist)
  85   (let* (;; PATH is a sort of pointer into the part of the lambda list we're
  86          ;; considering at this point in the code. PATH-0 is the root of the
  87          ;; lambda list, which is the initial value of PATH.
  88          (path-0 (if (or anonymousp sublist) whole-var `(cdr ,whole-var)))
  89          (path path-0) ; will change below
  90          (compiler-macro-whole (gensym "CMACRO-&WHOLE"))
  91          (now-processing :required)
  92          (maximum 0)
  93          (minimum 0)
  94          (keys ())
  95          (key-seen nil)
  96          (aux-seen nil)
  97          (optional-seen nil)
  98          ;; ANSI specifies that dotted lists are "treated exactly as if the
  99          ;; parameter name that ends the list had appeared preceded by &REST."
 100          ;; We force this behavior by transforming dotted lists into ordinary
 101          ;; lists with explicit &REST elements.
 102          (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll))
 103                            (reversed-result nil))
 104                           ((atom in-pdll)
 105                            (nreverse (if in-pdll
 106                                          (list* in-pdll '&rest reversed-result)
 107                                          reversed-result)))
 108                         (push (car in-pdll) reversed-result)))
 109          rest-name restp allow-other-keys-p env-arg-used)
 110     (when (member '&whole (rest lambda-list))
 111       (error "&WHOLE may only appear first in ~S lambda-list." context))
 112     ;; Special case compiler-macros: if car of the form is FUNCALL,
 113     ;; skip over it for destructuring, pretending cdr of the form is
 114     ;; the actual form. Save original for &WHOLE.
 115     (when (and (not sublist) (eq context 'define-compiler-macro))
 116       (push-let-binding compiler-macro-whole whole-var :system t)
 117       (push compiler-macro-whole *ignorable-vars*)
 118       (push-let-binding whole-var whole-var
 119                         :system t
 120                         :when `(not (eq 'funcall (car ,whole-var)))
 121                         ;; Do we need to SETF too?
 122                         :else `(setf ,whole-var (cdr ,whole-var))))
 123     (do ((rest-of-lambda-list lambda-list (cdr rest-of-lambda-list)))
 124         ((null rest-of-lambda-list))
 125       (macrolet ((process-sublist (var kind path)
 126                    (once-only ((var var))
 127                      `(if (listp ,var)
 128                           (let ((sublist-name (gensym ,kind)))
 129                             (push-sublist-binding sublist-name ,path ,var
 130                                                   name context error-fun)
 131                             (parse-defmacro-lambda-list ,var sublist-name name
 132                                                         context
 133                                                         :error-fun error-fun
 134                                                         :sublist t))
 135                           (push-let-binding ,var ,path))))
 136                  (normalize-singleton (var)
 137                    `(when (null (cdr ,var))
 138                      (setf (cdr ,var) (list *default-default*)))))
 139         (let ((var (car rest-of-lambda-list)))
 140           (typecase var
 141             (list
 142              (case now-processing
 143                ((:required)
 144                 (when restp
 145                   (defmacro-error (format nil "required argument after ~A"
 146                                           restp)
 147                       context name))
 148                 (when (process-sublist var "REQUIRED-" `(car ,path))
 149                   ;; Note &ENVIRONMENT from DEFSETF sublist
 150                   (aver (eq context 'defsetf))
 151                   (setf env-arg-used t))
 152                 (setq path `(cdr ,path)
 153                       minimum (1+ minimum)
 154                       maximum (1+ maximum)))
 155                ((:optionals)
 156                 (normalize-singleton var)
 157                 (destructuring-bind
 158                       (varname &optional default-form suppliedp-name)
 159                     var
 160                   (push-optional-binding varname default-form suppliedp-name
 161                                          :is-supplied-p `(not (null ,path))
 162                                          :path `(car ,path)
 163                                          :name name
 164                                          :context context
 165                                          :error-fun error-fun))
 166                 (setq path `(cdr ,path)
 167                       maximum (1+ maximum)))
 168                ((:keywords)
 169                 (normalize-singleton var)
 170                 (let* ((keyword-given (consp (car var)))
 171                        (variable (if keyword-given
 172                                      (cadar var)
 173                                      (car var)))
 174                        (keyword (if keyword-given
 175                                     (caar var)
 176                                     (keywordicate variable)))
 177                        (default-form (cadr var))
 178                        (suppliedp-name (caddr var)))
 179                   (push-optional-binding variable default-form suppliedp-name
 180                                          :is-supplied-p
 181                                          `(keyword-supplied-p ',keyword
 182                                                               ,rest-name)
 183                                          :path
 184                                          `(lookup-keyword ',keyword ,rest-name)
 185                                          :name name
 186                                          :context context
 187                                          :error-fun error-fun)
 188                   (push keyword keys)))
 189                ((:auxs)
 190                 (push-let-binding (car var) (cadr var)))))
 191             ((and symbol (not (eql nil)))
 192              (case var
 193                (&whole
 194                 (cond ((cdr rest-of-lambda-list)
 195                        (pop rest-of-lambda-list)
 196                        (process-sublist (car rest-of-lambda-list)
 197                                         "WHOLE-LIST-"
 198                                         (if (eq 'define-compiler-macro context)
 199                                             compiler-macro-whole
 200                                             whole-var)))
 201                       (t
 202                        (defmacro-error "&WHOLE" context name))))
 203                (&environment
 204                 (cond (env-illegal
 205                        (error "&ENVIRONMENT is not valid with ~S." context))
 206                       ;; DEFSETF explicitly allows &ENVIRONMENT, and we get
 207                       ;; it here in a sublist.
 208                       ((and sublist (neq context 'defsetf))
 209                        (error "&ENVIRONMENT is only valid at top level of ~
 210                              lambda-list."))
 211                       (env-arg-used
 212                        (error "Repeated &ENVIRONMENT.")))
 213                 (cond ((and (cdr rest-of-lambda-list)
 214                             (symbolp (cadr rest-of-lambda-list)))
 215                        (setq rest-of-lambda-list (cdr rest-of-lambda-list))
 216                        (check-defmacro-arg (car rest-of-lambda-list))
 217                        (setq *env-var* (car rest-of-lambda-list)
 218                              env-arg-used t))
 219                       (t
 220                        (defmacro-error "&ENVIRONMENT" context name))))
 221                ((&rest &body)
 222                 (cond ((or key-seen aux-seen)
 223                        (error "~A after ~A in ~A"
 224                               var (or key-seen aux-seen) context))
 225                       ((and (not restp) (cdr rest-of-lambda-list))
 226                        (setq rest-of-lambda-list (cdr rest-of-lambda-list)
 227                              restp var)
 228                        (process-sublist (car rest-of-lambda-list)
 229                                         "REST-LIST-" path))
 230                       (t
 231                        (defmacro-error (symbol-name var) context name))))
 232                (&optional
 233                 (when (or key-seen aux-seen restp)
 234                   (error "~A after ~A in ~A lambda-list."
 235                          var (or key-seen aux-seen restp) context))
 236                 (when optional-seen
 237                   (error "Multiple ~A in ~A lambda list." var context))
 238                 (setq now-processing :optionals
 239                       optional-seen var))
 240                (&key
 241                 (when aux-seen
 242                   (error "~A after ~A in ~A lambda-list." '&key '&aux context))
 243                 (when key-seen
 244                   (error "Multiple ~A in ~A lambda-list." '&key context))
 245                 (setf now-processing :keywords
 246                       rest-name (gensym "KEYWORDS-")
 247                       restp var
 248                       key-seen var)
 249                 (push rest-name *ignorable-vars*)
 250                 (push-let-binding rest-name path :system t))
 251                (&allow-other-keys
 252                 (unless (eq now-processing :keywords)
 253                   (error "~A outside ~A section of lambda-list in ~A."
 254                          var '&key context))
 255                 (when allow-other-keys-p
 256                   (error "Multiple ~A in ~A lambda-list." var context))
 257                 (setq allow-other-keys-p t))
 258                (&aux
 259                 (when (eq context 'defsetf)
 260                   (error "~A not allowed in a ~A lambda-list." var context))
 261                 (when aux-seen
 262                   (error "Multiple ~A in ~A lambda-list." '&aux context))
 263                 (setq now-processing :auxs
 264                       aux-seen var))
 265                ;; FIXME: Other lambda list keywords.
 266                (t
 267                 (case now-processing
 268                   ((:required)
 269                    (when restp
 270                      (defmacro-error (format nil "required argument after ~A"
 271                                              restp)
 272                          context name))
 273                    (push-let-binding var `(car ,path))
 274                    (setq minimum (1+ minimum)
 275                          maximum (1+ maximum)
 276                          path `(cdr ,path)))
 277                   ((:optionals)
 278                    (push-let-binding var `(car ,path)
 279                                      :when `(not (null ,path)))
 280                    (setq path `(cdr ,path)
 281                          maximum (1+ maximum)))
 282                   ((:keywords)
 283                    (let ((key (keywordicate var)))
 284                      (push-let-binding
 285                       var
 286                       `(lookup-keyword ,key ,rest-name)
 287                       :when `(keyword-supplied-p ,key ,rest-name))
 288                      (push key keys)))
 289                   ((:auxs)
 290                    (push-let-binding var nil))))))
 291             (t
 292              (error "non-symbol in lambda-list: ~S" var))))))
 293     (let (;; common subexpression, suitable for passing to functions
 294           ;; which expect a MAXIMUM argument regardless of whether
 295           ;; there actually is a maximum number of arguments
 296           ;; (expecting MAXIMUM=NIL when there is no maximum)
 297           (explicit-maximum (and (not restp) maximum)))
 298       (unless (and restp (zerop minimum))
 299         (push (let ((args-form (if (eq 'define-compiler-macro context)
 300                                    `(if (eq 'funcall (car ,whole-var))
 301                                         (cdr ,path-0)
 302                                         ,path-0)
 303                                    path-0)))
 304                 (with-unique-names (args)
 305                   `(let ((,args ,args-form))
 306                      (unless ,(if restp
 307                                   ;; (If RESTP, then the argument list
 308                                   ;; might be dotted, in which case
 309                                   ;; ordinary LENGTH won't work.)
 310                                   `(list-of-length-at-least-p ,args ,minimum)
 311                                   `(proper-list-of-length-p ,args
 312                                                             ,minimum
 313                                                             ,maximum))
 314                        ,(if (eq error-fun 'error)
 315                             `(arg-count-error ',context ',name ,args
 316                                               ',lambda-list ,minimum
 317                                               ,explicit-maximum)
 318                             `(,error-fun 'arg-count-error
 319                                          :kind ',context
 320                                          ,@(when name `(:name ',name))
 321                                          :args ,args
 322                                          :lambda-list ',lambda-list
 323                                          :minimum ,minimum
 324                                          :maximum ,explicit-maximum))))))
 325               *arg-tests*))
 326       (when key-seen
 327         (with-unique-names (problem info)
 328           (push `(multiple-value-bind (,problem ,info)
 329                      (verify-keywords ,rest-name
 330                                       ',keys
 331                                       ',allow-other-keys-p)
 332                    (when ,problem
 333                      (,error-fun
 334                       'defmacro-lambda-list-broken-key-list-error
 335                       :kind ',context
 336                       ,@(when name `(:name ',name))
 337                       :problem ,problem
 338                       :info ,info)))
 339                 *arg-tests*)))
 340       (values env-arg-used minimum explicit-maximum))))
 341
 342 ;;; We save space in macro definitions by calling this function.
 343 (defun arg-count-error (context name args lambda-list minimum maximum)
 344   (let (#-sb-xc-host
 345         (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
 346     (error 'arg-count-error
 347            :kind context
 348            :name name
 349            :args args
 350            :lambda-list lambda-list
 351            :minimum minimum
 352            :maximum maximum)))
 353
 354 (defun push-sublist-binding (variable path object name context error-fun)
 355   (check-defmacro-arg variable)
 356   (let ((var (gensym "TEMP-")))
 357     (push `(,variable
 358             (let ((,var ,path))
 359               (if (listp ,var)
 360                 ,var
 361                 (,error-fun 'defmacro-bogus-sublist-error
 362                             :kind ',context
 363                             ,@(when name `(:name ',name))
 364                             :object ,var
 365                             :lambda-list ',object))))
 366           *system-lets*)))
 367
 368 (defun push-let-binding (variable form
 369                          &key system when (else *default-default*))
 370   (check-defmacro-arg variable)
 371   (let ((let-form (if when
 372                       `(,variable (if ,when ,form ,else))
 373                       `(,variable ,form))))
 374     (if system
 375         (push let-form *system-lets*)
 376         (push let-form *user-lets*))))
 377
 378 (defun push-optional-binding (value-var init-form suppliedp-name
 379                               &key is-supplied-p path name context error-fun)
 380   (unless suppliedp-name
 381     (setq suppliedp-name (gensym "SUPPLIEDP-")))
 382   (push-let-binding suppliedp-name is-supplied-p :system t)
 383   (cond ((consp value-var)
 384          (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
 385            (push-sublist-binding whole-thing
 386                                  `(if ,suppliedp-name ,path ,init-form)
 387                                  value-var name context error-fun)
 388            (parse-defmacro-lambda-list value-var whole-thing name
 389                                        context
 390                                        :error-fun error-fun
 391                                        :sublist t)))
 392         ((symbolp value-var)
 393          (push-let-binding value-var path :when suppliedp-name :else init-form))
 394         (t
 395          (error "illegal optional variable name: ~S" value-var))))
 396
 397 (defun defmacro-error (problem context name)
 398   (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]"
 399          problem context name))
 400
 401 (defun check-defmacro-arg (arg)
 402   (when (or (and *env-var* (eq arg *env-var*))
 403             (member arg *system-lets* :key #'car)
 404             (member arg *user-lets* :key #'car))
 405     (error "variable ~S occurs more than once" arg)))
 406
 407 ;;; Determine whether KEY-LIST is a valid list of keyword/value pairs.
 408 ;;; Do not signal the error directly, 'cause we don't know how it
 409 ;;; should be signaled.
 410 (defun verify-keywords (key-list valid-keys allow-other-keys)
 411   (do ((already-processed nil)
 412        (unknown-keyword nil)
 413        (remaining key-list (cddr remaining)))
 414       ((null remaining)
 415        (if (and unknown-keyword
 416                 (not allow-other-keys)
 417                 (not (lookup-keyword :allow-other-keys key-list)))
 418            (values :unknown-keyword (list unknown-keyword valid-keys))
 419            (values nil nil)))
 420     (cond ((not (and (consp remaining) (listp (cdr remaining))))
 421            (return (values :dotted-list key-list)))
 422           ((null (cdr remaining))
 423            (return (values :odd-length key-list)))
 424           ((or (eq (car remaining) :allow-other-keys)
 425                (member (car remaining) valid-keys))
 426            (push (car remaining) already-processed))
 427           (t
 428            (setq unknown-keyword (car remaining))))))
 429
 430 (defun lookup-keyword (keyword key-list)
 431   (do ((remaining key-list (cddr remaining)))
 432       ((endp remaining))
 433     (when (eq keyword (car remaining))
 434       (return (cadr remaining)))))
 435
 436 (defun keyword-supplied-p (keyword key-list)
 437   (do ((remaining key-list (cddr remaining)))
 438       ((endp remaining))
 439     (when (eq keyword (car remaining))
 440       (return t))))