src/parse-lambda-list.lisp

   1 (in-package parenscript)
   2 ;;;; This software was taken from the SBCL system.  there are very few
   3 ;;;; changes, and one SBCL-specific thing left (sb-c::collect
   4
   5 ;;; if you have found this on google, THIS IS NOT AN SBCL SOURCE FILE
   6
   7 ;;; Break something like a lambda list (but not necessarily actually a
   8 ;;; lambda list, e.g. the representation of argument types which is
   9 ;;; used within an FTYPE specification) into its component parts. We
  10 ;;; return twelve values:
  11 ;;;  1. a list of the required args;
  12 ;;;  2. a list of the &OPTIONAL arg specs;
  13 ;;;  3. true if a &REST arg was specified;
  14 ;;;  4. the &REST arg;
  15 ;;;  5. true if &KEY args are present;
  16 ;;;  6. a list of the &KEY arg specs;
  17 ;;;  7. true if &ALLOW-OTHER-KEYS was specified.;
  18 ;;;  8. true if any &AUX is present (new in SBCL vs. CMU CL);
  19 ;;;  9. a list of the &AUX specifiers;
  20 ;;; 10. true if a &MORE arg was specified;
  21 ;;; 11. the &MORE context var;
  22 ;;; 12. the &MORE count var;
  23 ;;; 13. true if any lambda list keyword is present (only for
  24 ;;;     PARSE-LAMBDA-LIST-LIKE-THING).
  25 ;;;
  26 ;;; The top level lambda list syntax is checked for validity, but the
  27 ;;; arg specifiers are just passed through untouched. If something is
  28 ;;; wrong, we use COMPILER-ERROR, aborting compilation to the last
  29 ;;; recovery point.
  30 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  31   (defun collect-list-expander (n-value n-tail forms)
  32     (let ((n-res (gensym)))
  33       `(progn
  34         ,@(mapcar (lambda (form)
  35                     `(let ((,n-res (cons ,form nil)))
  36                       (cond (,n-tail
  37                              (setf (cdr ,n-tail) ,n-res)
  38                              (setq ,n-tail ,n-res))
  39                             (t
  40                              (setq ,n-tail ,n-res  ,n-value ,n-res)))))
  41                   forms)
  42         ,n-value))))
  43
  44 (defmacro collect (collections &body body)
  45   (let ((macros ())
  46         (binds ()))
  47     (dolist (spec collections)
  48                                         ;      (unless (proper-list-of-length-p spec 1 3)
  49                                         ;        (error "malformed collection specifier: ~S" spec))
  50       (let* ((name (first spec))
  51              (default (second spec))
  52              (kind (or (third spec) 'collect))
  53              (n-value (gensym (concatenate 'string
  54                                            (symbol-name name)
  55                                            "-N-VALUE-"))))
  56         (push `(,n-value ,default) binds)
  57         (if (eq kind 'collect)
  58             (let ((n-tail (gensym (concatenate 'string
  59                                                (symbol-name name)
  60                                                "-N-TAIL-"))))
  61               (if default
  62                   (push `(,n-tail (last ,n-value)) binds)
  63                   (push n-tail binds))
  64                 (push `(,name (&rest args)
  65                         (collect-list-expander ',n-value ',n-tail args))
  66                       macros))
  67             (push `(,name (&rest args)
  68                     (collect-normal-expander ',n-value ',kind args))
  69                   macros))))
  70     `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
  71
  72 (defparameter *lambda-list-keywords*
  73  '(&allow-other-keys &aux &body &environment &key &optional &rest &whole))
  74
  75 (defun style-warn (&rest args) (apply #'format t args))
  76
  77
  78 (defun parse-lambda-list-like-thing (list)
  79  (collect ((required)
  80             (optional)
  81             (keys)
  82             (aux))
  83     (let ((restp nil)
  84           (rest nil)
  85           (morep nil)
  86           (more-context nil)
  87           (more-count nil)
  88           (keyp nil)
  89           (auxp nil)
  90           (allowp nil)
  91           (state :required))
  92       (declare (type (member :allow-other-keys :aux
  93                              :key
  94                              :more-context :more-count
  95                              :optional
  96                              :post-more :post-rest
  97                              :required :rest)
  98                      state))
  99       (dolist (arg list)
 100         (if (member arg *lambda-list-keywords*)
 101             (case arg
 102               (&optional
 103                (unless (eq state :required)
 104                  (format t "misplaced &OPTIONAL in lambda list: ~S"
 105                                  list))
 106                (setq state :optional))
 107               (&rest
 108                (unless (member state '(:required :optional))
 109                  (format t "misplaced &REST in lambda list: ~S" list))
 110                (setq state :rest))
 111               (&more
 112                (unless (member state '(:required :optional))
 113                  (format t "misplaced &MORE in lambda list: ~S" list))
 114                (setq morep t
 115                      state :more-context))
 116               (&key
 117                (unless (member state
 118                                '(:required :optional :post-rest :post-more))
 119                  (format t "misplaced &KEY in lambda list: ~S" list))
 120                #-sb-xc-host
 121                (when (optional)
 122                  (format t
 123                   "&OPTIONAL and &KEY found in the same lambda list: ~S" list))
 124                (setq keyp t
 125                      state :key))
 126               (&allow-other-keys
 127                (unless (eq state ':key)
 128                  (format t "misplaced &ALLOW-OTHER-KEYS in ~
 129                                   lambda list: ~S"
 130                                  list))
 131                (setq allowp t
 132                      state :allow-other-keys))
 133               (&aux
 134                (when (member state '(:rest :more-context :more-count))
 135                  (format t "misplaced &AUX in lambda list: ~S" list))
 136                (when auxp
 137                  (format t "multiple &AUX in lambda list: ~S" list))
 138                (setq auxp t
 139                      state :aux))
 140               (t (format t "unknown LAMBDA-LIST-KEYWORD in lambda list: ~S." arg)))
 141             (progn
 142               (when (symbolp arg)
 143                 (let ((name (symbol-name arg)))
 144                   (when (and (plusp (length name))
 145                              (char= (char name 0) #\&))
 146                     (style-warn
 147                      "suspicious variable in lambda list: ~S." arg))))
 148               (case state
 149                 (:required (required arg))
 150                 (:optional (optional arg))
 151                 (:rest
 152                  (setq restp t
 153                        rest arg
 154                        state :post-rest))
 155                 (:more-context
 156                  (setq more-context arg
 157                        state :more-count))
 158                 (:more-count
 159                  (setq more-count arg
 160                        state :post-more))
 161                 (:key (keys arg))
 162                 (:aux (aux arg))
 163                 (t
 164                  (format t "found garbage in lambda list when expecting ~
 165                                   a keyword: ~S"
 166                                  arg))))))
 167       (when (eq state :rest)
 168         (format t "&REST without rest variable"))
 169
 170       (values (required) (optional) restp rest keyp (keys) allowp auxp (aux)
 171               morep more-context more-count
 172               (not (eq state :required))))))
 173
 174 ;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument
 175 ;;; really *is* a lambda list, not just a "lambda-list-like thing", so
 176 ;;; can barf on things which're illegal as arguments in lambda lists
 177 ;;; even if they could conceivably be legal in not-quite-a-lambda-list
 178 ;;; weirdosities
 179 (defun parse-lambda-list (lambda-list)
 180
 181   ;; Classify parameters without checking their validity individually.
 182   (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
 183                         morep more-context more-count)
 184       (parse-lambda-list-like-thing lambda-list)
 185
 186     ;; Check validity of parameters.
 187     (flet ((need-symbol (x why)
 188              (unless (or (symbolp x) t)
 189                (format t "~A is not a symbol: ~S" why x))))
 190       (dolist (i required)
 191         (need-symbol i "Required argument"))
 192       (dolist (i optional)
 193         (typecase i
 194           (symbol)
 195           (cons
 196            (destructuring-bind (var &optional init-form supplied-p) i
 197              (declare (ignore init-form supplied-p))
 198              (need-symbol var "&OPTIONAL parameter name")))
 199           (t
 200            (format t "&OPTIONAL parameter is not a symbol or cons: ~S"
 201                            i))))
 202       (when restp
 203         (need-symbol rest "&REST argument"))
 204       (when keyp
 205         (dolist (i keys)
 206           (typecase i
 207             (symbol)
 208             (cons
 209              (destructuring-bind (var-or-kv &optional init-form supplied-p) i
 210                (declare (ignore init-form supplied-p))
 211                (if (consp var-or-kv)
 212                    (destructuring-bind (keyword-name var) var-or-kv
 213                      (declare (ignore keyword-name))
 214                      (need-symbol var "&KEY parameter name"))
 215                    (need-symbol var-or-kv "&KEY parameter name"))))
 216             (t
 217              (format t "&KEY parameter is not a symbol or cons: ~S"
 218                              i))))))
 219
 220     ;; Voila.
 221     (values required optional restp rest keyp keys allowp auxp aux
 222             morep more-context more-count)))