Commit | Line | Data |
---|---|---|
83d10fe4 VS |
1 | (in-package :parenscript) |
2 | ||
3 | ;;;; This software was taken from the SBCL system, mostly verbatim. | |
9da682ca RD |
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). | |
bbea4c83 | 25 | ;;; 14. the &KEY-OBJECT var |
9da682ca RD |
26 | ;;; |
27 | ;;; The top level lambda list syntax is checked for validity, but the | |
83d10fe4 VS |
28 | ;;; arg specifiers are just passed through untouched. |
29 | ||
46f794a4 | 30 | (eval-when (:compile-toplevel :load-toplevel :execute) |
9da682ca RD |
31 | (defun collect-list-expander (n-value n-tail forms) |
32 | (let ((n-res (gensym))) | |
33 | `(progn | |
b508414b TC |
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)))) | |
9da682ca RD |
43 | |
44 | (defmacro collect (collections &body body) | |
45 | (let ((macros ()) | |
b508414b | 46 | (binds ())) |
9da682ca | 47 | (dolist (spec collections) |
45c9f9c2 TC |
48 | ;;(unless (proper-list-of-length-p spec 1 3) |
49 | ;; (error "malformed collection specifier: ~S" spec)) | |
9da682ca | 50 | (let* ((name (first spec)) |
b508414b TC |
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)))) | |
9da682ca RD |
70 | `(macrolet ,macros (let* ,(nreverse binds) ,@body)))) |
71 | ||
72 | (defparameter *lambda-list-keywords* | |
bbea4c83 | 73 | '(&allow-other-keys &aux &body &environment &key &key-object &optional &rest &whole)) |
9da682ca RD |
74 | |
75 | (defun style-warn (&rest args) (apply #'format t args)) | |
76 | ||
9da682ca RD |
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) | |
b508414b | 90 | (key-object nil) |
9da682ca RD |
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 | |
bbea4c83 | 97 | :required :rest |
b508414b | 98 | :key-object :post-key) |
9da682ca RD |
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" | |
b508414b | 106 | list)) |
9da682ca RD |
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)) | |
9da682ca | 121 | (when (optional) |
83d10fe4 | 122 | (format t "&OPTIONAL and &KEY found in the same lambda list: ~S" list)) |
9da682ca RD |
123 | (setq keyp t |
124 | state :key)) | |
125 | (&allow-other-keys | |
bbea4c83 | 126 | (unless (member state '(:key :post-key)) |
9da682ca RD |
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)) | |
b508414b TC |
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)) | |
9da682ca RD |
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)) | |
b508414b | 165 | (:key-object (setf key-object arg) (setf state :post-key)) |
9da682ca RD |
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 | |
bbea4c83 | 176 | (not (eq state :required)) |
b508414b | 177 | key-object)))) |
9da682ca RD |
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) | |
9da682ca RD |
185 | ;; Classify parameters without checking their validity individually. |
186 | (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux | |
bbea4c83 | 187 | morep more-context more-count beyond-requireds? key-object) |
9da682ca | 188 | (parse-lambda-list-like-thing lambda-list) |
bbea4c83 | 189 | (declare (ignore beyond-requireds?)) |
9da682ca RD |
190 | ;; Check validity of parameters. |
191 | (flet ((need-symbol (x why) | |
c3f0c22a | 192 | (unless (symbolp x) |
9da682ca RD |
193 | (format t "~A is not a symbol: ~S" why x)))) |
194 | (dolist (i required) | |
195 | (need-symbol i "Required argument")) | |
196 | (dolist (i optional) | |
197 | (typecase i | |
198 | (symbol) | |
199 | (cons | |
200 | (destructuring-bind (var &optional init-form supplied-p) i | |
201 | (declare (ignore init-form supplied-p)) | |
202 | (need-symbol var "&OPTIONAL parameter name"))) | |
203 | (t | |
204 | (format t "&OPTIONAL parameter is not a symbol or cons: ~S" | |
205 | i)))) | |
206 | (when restp | |
207 | (need-symbol rest "&REST argument")) | |
208 | (when keyp | |
209 | (dolist (i keys) | |
210 | (typecase i | |
211 | (symbol) | |
212 | (cons | |
213 | (destructuring-bind (var-or-kv &optional init-form supplied-p) i | |
214 | (declare (ignore init-form supplied-p)) | |
215 | (if (consp var-or-kv) | |
216 | (destructuring-bind (keyword-name var) var-or-kv | |
217 | (declare (ignore keyword-name)) | |
218 | (need-symbol var "&KEY parameter name")) | |
219 | (need-symbol var-or-kv "&KEY parameter name")))) | |
220 | (t | |
221 | (format t "&KEY parameter is not a symbol or cons: ~S" | |
222 | i)))))) | |
9da682ca RD |
223 | ;; Voila. |
224 | (values required optional restp rest keyp keys allowp auxp aux | |
bbea4c83 | 225 | morep more-context more-count key-object))) |