| 1 | (in-package :parenscript) |
| 2 | |
| 3 | ;;;; This software was taken from the SBCL system, mostly verbatim. |
| 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. |
| 29 | |
| 30 | (eval-when (: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 &key-object &optional &rest &whole)) |
| 74 | |
| 75 | (defun style-warn (&rest args) (apply #'format t args)) |
| 76 | |
| 77 | (defun parse-lambda-list-like-thing (list) |
| 78 | (collect ((required) |
| 79 | (optional) |
| 80 | (keys) |
| 81 | (aux)) |
| 82 | (let ((restp nil) |
| 83 | (rest nil) |
| 84 | (morep nil) |
| 85 | (more-context nil) |
| 86 | (more-count nil) |
| 87 | (keyp nil) |
| 88 | (auxp nil) |
| 89 | (allowp nil) |
| 90 | (key-object 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 | :key-object :post-key) |
| 99 | state)) |
| 100 | (dolist (arg list) |
| 101 | (if (member arg *lambda-list-keywords*) |
| 102 | (case arg |
| 103 | (&optional |
| 104 | (unless (eq state :required) |
| 105 | (format t "misplaced &OPTIONAL in lambda list: ~S" |
| 106 | list)) |
| 107 | (setq state :optional)) |
| 108 | (&rest |
| 109 | (unless (member state '(:required :optional)) |
| 110 | (format t "misplaced &REST in lambda list: ~S" list)) |
| 111 | (setq state :rest)) |
| 112 | (&more |
| 113 | (unless (member state '(:required :optional)) |
| 114 | (format t "misplaced &MORE in lambda list: ~S" list)) |
| 115 | (setq morep t |
| 116 | state :more-context)) |
| 117 | (&key |
| 118 | (unless (member state |
| 119 | '(:required :optional :post-rest :post-more)) |
| 120 | (format t "misplaced &KEY in lambda list: ~S" list)) |
| 121 | (when (optional) |
| 122 | (format t "&OPTIONAL and &KEY found in the same lambda list: ~S" list)) |
| 123 | (setq keyp t |
| 124 | state :key)) |
| 125 | (&allow-other-keys |
| 126 | (unless (member state '(:key :post-key)) |
| 127 | (format t "misplaced &ALLOW-OTHER-KEYS in ~ |
| 128 | lambda list: ~S" |
| 129 | list)) |
| 130 | (setq allowp t |
| 131 | state :allow-other-keys)) |
| 132 | (&aux |
| 133 | (when (member state '(:rest :more-context :more-count)) |
| 134 | (format t "misplaced &AUX in lambda list: ~S" list)) |
| 135 | (when auxp |
| 136 | (format t "multiple &AUX in lambda list: ~S" list)) |
| 137 | (setq auxp t |
| 138 | state :aux)) |
| 139 | (&key-object |
| 140 | (unless (member state '(:key :allow-other-keys)) |
| 141 | (format t "&key-object misplaced in lmabda list: ~S. Belongs after &key" list)) |
| 142 | (setf state :key-object)) |
| 143 | (t (format t "unknown LAMBDA-LIST-KEYWORD in lambda list: ~S." arg))) |
| 144 | (progn |
| 145 | (when (symbolp arg) |
| 146 | (let ((name (symbol-name arg))) |
| 147 | (when (and (plusp (length name)) |
| 148 | (char= (char name 0) #\&)) |
| 149 | (style-warn |
| 150 | "suspicious variable in lambda list: ~S." arg)))) |
| 151 | (case state |
| 152 | (:required (required arg)) |
| 153 | (:optional (optional arg)) |
| 154 | (:rest |
| 155 | (setq restp t |
| 156 | rest arg |
| 157 | state :post-rest)) |
| 158 | (:more-context |
| 159 | (setq more-context arg |
| 160 | state :more-count)) |
| 161 | (:more-count |
| 162 | (setq more-count arg |
| 163 | state :post-more)) |
| 164 | (:key (keys arg)) |
| 165 | (:key-object (setf key-object arg) (setf state :post-key)) |
| 166 | (:aux (aux arg)) |
| 167 | (t |
| 168 | (format t "found garbage in lambda list when expecting ~ |
| 169 | a keyword: ~S" |
| 170 | arg)))))) |
| 171 | (when (eq state :rest) |
| 172 | (format t "&REST without rest variable")) |
| 173 | |
| 174 | (values (required) (optional) restp rest keyp (keys) allowp auxp (aux) |
| 175 | morep more-context more-count |
| 176 | (not (eq state :required)) |
| 177 | key-object)))) |
| 178 | |
| 179 | ;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument |
| 180 | ;;; really *is* a lambda list, not just a "lambda-list-like thing", so |
| 181 | ;;; can barf on things which're illegal as arguments in lambda lists |
| 182 | ;;; even if they could conceivably be legal in not-quite-a-lambda-list |
| 183 | ;;; weirdosities |
| 184 | (defun parse-lambda-list (lambda-list) |
| 185 | |
| 186 | ;; Classify parameters without checking their validity individually. |
| 187 | (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux |
| 188 | morep more-context more-count beyond-requireds? key-object) |
| 189 | (parse-lambda-list-like-thing lambda-list) |
| 190 | (declare (ignore beyond-requireds?)) |
| 191 | |
| 192 | ;; Check validity of parameters. |
| 193 | (flet ((need-symbol (x why) |
| 194 | (unless (symbolp x) |
| 195 | (format t "~A is not a symbol: ~S" why x)))) |
| 196 | (dolist (i required) |
| 197 | (need-symbol i "Required argument")) |
| 198 | (dolist (i optional) |
| 199 | (typecase i |
| 200 | (symbol) |
| 201 | (cons |
| 202 | (destructuring-bind (var &optional init-form supplied-p) i |
| 203 | (declare (ignore init-form supplied-p)) |
| 204 | (need-symbol var "&OPTIONAL parameter name"))) |
| 205 | (t |
| 206 | (format t "&OPTIONAL parameter is not a symbol or cons: ~S" |
| 207 | i)))) |
| 208 | (when restp |
| 209 | (need-symbol rest "&REST argument")) |
| 210 | (when keyp |
| 211 | (dolist (i keys) |
| 212 | (typecase i |
| 213 | (symbol) |
| 214 | (cons |
| 215 | (destructuring-bind (var-or-kv &optional init-form supplied-p) i |
| 216 | (declare (ignore init-form supplied-p)) |
| 217 | (if (consp var-or-kv) |
| 218 | (destructuring-bind (keyword-name var) var-or-kv |
| 219 | (declare (ignore keyword-name)) |
| 220 | (need-symbol var "&KEY parameter name")) |
| 221 | (need-symbol var-or-kv "&KEY parameter name")))) |
| 222 | (t |
| 223 | (format t "&KEY parameter is not a symbol or cons: ~S" |
| 224 | i)))))) |
| 225 | |
| 226 | ;; Voila. |
| 227 | (values required optional restp rest keyp keys allowp auxp aux |
| 228 | morep more-context more-count key-object))) |