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
5 ;;; if you have found this on google, THIS IS NOT AN SBCL SOURCE FILE
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;
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
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
31 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
32 (defun collect-list-expander (n-value n-tail forms
)
33 (let ((n-res (gensym)))
35 ,@(mapcar (lambda (form)
36 `(let ((,n-res
(cons ,form nil
)))
38 (setf (cdr ,n-tail
) ,n-res
)
39 (setq ,n-tail
,n-res
))
41 (setq ,n-tail
,n-res
,n-value
,n-res
)))))
45 (defmacro collect
(collections &body body
)
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
57 (push `(,n-value
,default
) binds
)
58 (if (eq kind
'collect
)
59 (let ((n-tail (gensym (concatenate 'string
63 (push `(,n-tail
(last ,n-value
)) binds
)
65 (push `(,name
(&rest args
)
66 (collect-list-expander ',n-value
',n-tail args
))
68 (push `(,name
(&rest args
)
69 (collect-normal-expander ',n-value
',kind args
))
71 `(macrolet ,macros
(let* ,(nreverse binds
) ,@body
))))
73 (defparameter *lambda-list-keywords
*
74 '(&allow-other-keys
&aux
&body
&environment
&key
&key-object
&optional
&rest
&whole
))
76 (defun style-warn (&rest args
) (apply #'format t args
))
78 (defun parse-lambda-list-like-thing (list)
93 (declare (type (member :allow-other-keys
:aux
95 :more-context
:more-count
99 :key-object
:post-key
)
102 (if (member arg
*lambda-list-keywords
*)
105 (unless (eq state
:required
)
106 (format t
"misplaced &OPTIONAL in lambda list: ~S"
108 (setq state
:optional
))
110 (unless (member state
'(:required
:optional
))
111 (format t
"misplaced &REST in lambda list: ~S" list
))
114 (unless (member state
'(:required
:optional
))
115 (format t
"misplaced &MORE in lambda list: ~S" list
))
117 state
:more-context
))
119 (unless (member state
120 '(:required
:optional
:post-rest
:post-more
))
121 (format t
"misplaced &KEY in lambda list: ~S" list
))
125 "&OPTIONAL and &KEY found in the same lambda list: ~S" list
))
129 (unless (member state
'(:key
:post-key
))
130 (format t
"misplaced &ALLOW-OTHER-KEYS in ~
134 state
:allow-other-keys
))
136 (when (member state
'(:rest
:more-context
:more-count
))
137 (format t
"misplaced &AUX in lambda list: ~S" list
))
139 (format t
"multiple &AUX in lambda list: ~S" list
))
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
)))
149 (let ((name (symbol-name arg
)))
150 (when (and (plusp (length name
))
151 (char= (char name
0) #\
&))
153 "suspicious variable in lambda list: ~S." arg
))))
155 (:required
(required arg
))
156 (:optional
(optional arg
))
162 (setq more-context arg
168 (:key-object
(setf key-object arg
) (setf state
:post-key
))
171 (format t
"found garbage in lambda list when expecting ~
174 (when (eq state
:rest
)
175 (format t
"&REST without rest variable"))
177 (values (required) (optional) restp rest keyp
(keys) allowp auxp
(aux)
178 morep more-context more-count
179 (not (eq state
:required
))
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
187 (defun parse-lambda-list (lambda-list)
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?
))
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
))))
200 (need-symbol i
"Required argument"))
205 (destructuring-bind (var &optional init-form supplied-p
) i
206 (declare (ignore init-form supplied-p
))
207 (need-symbol var
"&OPTIONAL parameter name")))
209 (format t
"&OPTIONAL parameter is not a symbol or cons: ~S"
212 (need-symbol rest
"&REST argument"))
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"))))
226 (format t
"&KEY parameter is not a symbol or cons: ~S"
230 (values required optional restp rest keyp keys allowp auxp aux
231 morep more-context more-count key-object
)))