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