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