Commit | Line | Data |
---|---|---|
9da682ca RD |
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). | |
bbea4c83 | 25 | ;;; 14. the &KEY-OBJECT var |
9da682ca RD |
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. | |
46f794a4 | 31 | (eval-when (:compile-toplevel :load-toplevel :execute) |
9da682ca RD |
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* | |
bbea4c83 | 74 | '(&allow-other-keys &aux &body &environment &key &key-object &optional &rest &whole)) |
9da682ca RD |
75 | |
76 | (defun style-warn (&rest args) (apply #'format t args)) | |
77 | ||
9da682ca RD |
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) | |
bbea4c83 | 91 | (key-object nil) |
9da682ca RD |
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 | |
bbea4c83 RD |
98 | :required :rest |
99 | :key-object :post-key) | |
9da682ca RD |
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" | |
46f794a4 | 107 | list)) |
9da682ca RD |
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 | |
bbea4c83 | 129 | (unless (member state '(:key :post-key)) |
9da682ca RD |
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)) | |
bbea4c83 RD |
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)) | |
9da682ca RD |
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)) | |
bbea4c83 | 168 | (:key-object (setf key-object arg) (setf state :post-key)) |
9da682ca RD |
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 | |
bbea4c83 RD |
179 | (not (eq state :required)) |
180 | key-object)))) | |
9da682ca RD |
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 | |
bbea4c83 | 191 | morep more-context more-count beyond-requireds? key-object) |
9da682ca | 192 | (parse-lambda-list-like-thing lambda-list) |
bbea4c83 | 193 | (declare (ignore beyond-requireds?)) |
9da682ca RD |
194 | |
195 | ;; Check validity of parameters. | |
196 | (flet ((need-symbol (x why) | |
c3f0c22a | 197 | (unless (symbolp x) |
9da682ca RD |
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 | |
bbea4c83 | 231 | morep more-context more-count key-object))) |