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 ;;; 14. the &KEY-OBJECT var
  26 ;;;
  27 ;;; The top level lambda list syntax is checked for validity, but the
  28 ;;; arg specifiers are just passed through untouched. If something is
  29 ;;; wrong, we use COMPILER-ERROR, aborting compilation to the last
  30 ;;; recovery point.
  31 (eval-when (:compile-toplevel :load-toplevel :execute)
  32   (defun collect-list-expander (n-value n-tail forms)
  33     (let ((n-res (gensym)))
  34       `(progn
  35         ,@(mapcar (lambda (form)
  36                     `(let ((,n-res (cons ,form nil)))
  37                       (cond (,n-tail
  38                              (setf (cdr ,n-tail) ,n-res)
  39                              (setq ,n-tail ,n-res))
  40                             (t
  41                              (setq ,n-tail ,n-res  ,n-value ,n-res)))))
  42                   forms)
  43         ,n-value))))
  44
  45 (defmacro collect (collections &body body)
  46   (let ((macros ())
  47         (binds ()))
  48     (dolist (spec collections)
  49                                         ;      (unless (proper-list-of-length-p spec 1 3)
  50                                         ;        (error "malformed collection specifier: ~S" spec))
  51       (let* ((name (first spec))
  52              (default (second spec))
  53              (kind (or (third spec) 'collect))
  54              (n-value (gensym (concatenate 'string
  55                                            (symbol-name name)
  56                                            "-N-VALUE-"))))
  57         (push `(,n-value ,default) binds)
  58         (if (eq kind 'collect)
  59             (let ((n-tail (gensym (concatenate 'string
  60                                                (symbol-name name)
  61                                                "-N-TAIL-"))))
  62               (if default
  63                   (push `(,n-tail (last ,n-value)) binds)
  64                   (push n-tail binds))
  65                 (push `(,name (&rest args)
  66                         (collect-list-expander ',n-value ',n-tail args))
  67                       macros))
  68             (push `(,name (&rest args)
  69                     (collect-normal-expander ',n-value ',kind args))
  70                   macros))))
  71     `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
  72
  73 (defparameter *lambda-list-keywords*
  74  '(&allow-other-keys &aux &body &environment &key &key-object &optional &rest &whole))
  75
  76 (defun style-warn (&rest args) (apply #'format t args))
  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           (key-object nil)
  92           (state :required))
  93       (declare (type (member :allow-other-keys :aux
  94                              :key
  95                              :more-context :more-count
  96                              :optional
  97                              :post-more :post-rest
  98                              :required :rest
  99                              :key-object :post-key)
 100                      state))
 101       (dolist (arg list)
 102         (if (member arg *lambda-list-keywords*)
 103             (case arg
 104               (&optional
 105                (unless (eq state :required)
 106                  (format t "misplaced &OPTIONAL in lambda list: ~S"
 107                          list))
 108                (setq state :optional))
 109               (&rest
 110                (unless (member state '(:required :optional))
 111                  (format t "misplaced &REST in lambda list: ~S" list))
 112                (setq state :rest))
 113               (&more
 114                (unless (member state '(:required :optional))
 115                  (format t "misplaced &MORE in lambda list: ~S" list))
 116                (setq morep t
 117                      state :more-context))
 118               (&key
 119                (unless (member state
 120                                '(:required :optional :post-rest :post-more))
 121                  (format t "misplaced &KEY in lambda list: ~S" list))
 122                #-sb-xc-host
 123                (when (optional)
 124                  (format t
 125                   "&OPTIONAL and &KEY found in the same lambda list: ~S" list))
 126                (setq keyp t
 127                      state :key))
 128               (&allow-other-keys
 129                (unless (member state '(:key :post-key))
 130                  (format t "misplaced &ALLOW-OTHER-KEYS in ~
 131                                   lambda list: ~S"
 132                                  list))
 133                (setq allowp t
 134                      state :allow-other-keys))
 135               (&aux
 136                (when (member state '(:rest :more-context :more-count))
 137                  (format t "misplaced &AUX in lambda list: ~S" list))
 138                (when auxp
 139                  (format t "multiple &AUX in lambda list: ~S" list))
 140                (setq auxp t
 141                      state :aux))
 142               (&key-object
 143                (unless (member state '(:key :allow-other-keys))
 144                  (format t "&key-object misplaced in lmabda list: ~S. Belongs after &key" list))
 145                (setf state :key-object))
 146               (t (format t "unknown LAMBDA-LIST-KEYWORD in lambda list: ~S." arg)))
 147             (progn
 148               (when (symbolp arg)
 149                 (let ((name (symbol-name arg)))
 150                   (when (and (plusp (length name))
 151                              (char= (char name 0) #\&))
 152                     (style-warn
 153                      "suspicious variable in lambda list: ~S." arg))))
 154               (case state
 155                 (:required (required arg))
 156                 (:optional (optional arg))
 157                 (:rest
 158                  (setq restp t
 159                        rest arg
 160                        state :post-rest))
 161                 (:more-context
 162                  (setq more-context arg
 163                        state :more-count))
 164                 (:more-count
 165                  (setq more-count arg
 166                        state :post-more))
 167                 (:key (keys arg))
 168                 (:key-object (setf key-object arg) (setf state :post-key))
 169                 (:aux (aux arg))
 170                 (t
 171                  (format t "found garbage in lambda list when expecting ~
 172                                   a keyword: ~S"
 173                                  arg))))))
 174       (when (eq state :rest)
 175         (format t "&REST without rest variable"))
 176
 177       (values (required) (optional) restp rest keyp (keys) allowp auxp (aux)
 178               morep more-context more-count
 179               (not (eq state :required))
 180               key-object))))
 181
 182 ;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument
 183 ;;; really *is* a lambda list, not just a "lambda-list-like thing", so
 184 ;;; can barf on things which're illegal as arguments in lambda lists
 185 ;;; even if they could conceivably be legal in not-quite-a-lambda-list
 186 ;;; weirdosities
 187 (defun parse-lambda-list (lambda-list)
 188
 189   ;; Classify parameters without checking their validity individually.
 190   (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
 191                         morep more-context more-count beyond-requireds? key-object)
 192       (parse-lambda-list-like-thing lambda-list)
 193     (declare (ignore beyond-requireds?))
 194
 195     ;; Check validity of parameters.
 196     (flet ((need-symbol (x why)
 197              (unless (or (symbolp x) t)
 198                (format t "~A is not a symbol: ~S" why x))))
 199       (dolist (i required)
 200         (need-symbol i "Required argument"))
 201       (dolist (i optional)
 202         (typecase i
 203           (symbol)
 204           (cons
 205            (destructuring-bind (var &optional init-form supplied-p) i
 206              (declare (ignore init-form supplied-p))
 207              (need-symbol var "&OPTIONAL parameter name")))
 208           (t
 209            (format t "&OPTIONAL parameter is not a symbol or cons: ~S"
 210                            i))))
 211       (when restp
 212         (need-symbol rest "&REST argument"))
 213       (when keyp
 214         (dolist (i keys)
 215           (typecase i
 216             (symbol)
 217             (cons
 218              (destructuring-bind (var-or-kv &optional init-form supplied-p) i
 219                (declare (ignore init-form supplied-p))
 220                (if (consp var-or-kv)
 221                    (destructuring-bind (keyword-name var) var-or-kv
 222                      (declare (ignore keyword-name))
 223                      (need-symbol var "&KEY parameter name"))
 224                    (need-symbol var-or-kv "&KEY parameter name"))))
 225             (t
 226              (format t "&KEY parameter is not a symbol or cons: ~S"
 227                              i))))))
 228
 229     ;; Voila.
 230     (values required optional restp rest keyp keys allowp auxp aux
 231             morep more-context more-count key-object)))