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