1 (in-package :parenscript
)
3 ;;;; This software was taken from the SBCL system, mostly verbatim.
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.
30 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
31 (defun collect-list-expander (n-value n-tail forms
)
32 (let ((n-res (gensym)))
34 ,@(mapcar (lambda (form)
35 `(let ((,n-res
(cons ,form nil
)))
37 (setf (cdr ,n-tail
) ,n-res
)
38 (setq ,n-tail
,n-res
))
40 (setq ,n-tail
,n-res
,n-value
,n-res
)))))
44 (defmacro collect
(collections &body body
)
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
56 (push `(,n-value
,default
) binds
)
57 (if (eq kind
'collect
)
58 (let ((n-tail (gensym (concatenate 'string
62 (push `(,n-tail
(last ,n-value
)) binds
)
64 (push `(,name
(&rest args
)
65 (collect-list-expander ',n-value
',n-tail args
))
67 (push `(,name
(&rest args
)
68 (collect-normal-expander ',n-value
',kind args
))
70 `(macrolet ,macros
(let* ,(nreverse binds
) ,@body
))))
72 (defparameter *lambda-list-keywords
*
73 '(&allow-other-keys
&aux
&body
&environment
&key
&key-object
&optional
&rest
&whole
))
75 (defun style-warn (&rest args
) (apply #'format t args
))
77 (defun parse-lambda-list-like-thing (list)
92 (declare (type (member :allow-other-keys
:aux
94 :more-context
:more-count
98 :key-object
:post-key
)
101 (if (member arg
*lambda-list-keywords
*)
104 (unless (eq state
:required
)
105 (format t
"misplaced &OPTIONAL in lambda list: ~S"
107 (setq state
:optional
))
109 (unless (member state
'(:required
:optional
))
110 (format t
"misplaced &REST in lambda list: ~S" list
))
113 (unless (member state
'(:required
:optional
))
114 (format t
"misplaced &MORE in lambda list: ~S" list
))
116 state
:more-context
))
118 (unless (member state
119 '(:required
:optional
:post-rest
:post-more
))
120 (format t
"misplaced &KEY in lambda list: ~S" list
))
122 (format t
"&OPTIONAL and &KEY found in the same lambda list: ~S" list
))
126 (unless (member state
'(:key
:post-key
))
127 (format t
"misplaced &ALLOW-OTHER-KEYS in ~
131 state
:allow-other-keys
))
133 (when (member state
'(:rest
:more-context
:more-count
))
134 (format t
"misplaced &AUX in lambda list: ~S" list
))
136 (format t
"multiple &AUX in lambda list: ~S" list
))
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
)))
146 (let ((name (symbol-name arg
)))
147 (when (and (plusp (length name
))
148 (char= (char name
0) #\
&))
150 "suspicious variable in lambda list: ~S." arg
))))
152 (:required
(required arg
))
153 (:optional
(optional arg
))
159 (setq more-context arg
165 (:key-object
(setf key-object arg
) (setf state
:post-key
))
168 (format t
"found garbage in lambda list when expecting ~
171 (when (eq state
:rest
)
172 (format t
"&REST without rest variable"))
174 (values (required) (optional) restp rest keyp
(keys) allowp auxp
(aux)
175 morep more-context more-count
176 (not (eq state
:required
))
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
184 (defun parse-lambda-list (lambda-list)
185 ;; Classify parameters without checking their validity individually.
186 (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
187 morep more-context more-count beyond-requireds? key-object
)
188 (parse-lambda-list-like-thing lambda-list
)
189 (declare (ignore beyond-requireds?
))
190 ;; Check validity of parameters.
191 (flet ((need-symbol (x why
)
193 (format t
"~A is not a symbol: ~S" why x
))))
195 (need-symbol i
"Required argument"))
200 (destructuring-bind (var &optional init-form supplied-p
) i
201 (declare (ignore init-form supplied-p
))
202 (need-symbol var
"&OPTIONAL parameter name")))
204 (format t
"&OPTIONAL parameter is not a symbol or cons: ~S"
207 (need-symbol rest
"&REST argument"))
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"))))
221 (format t
"&KEY parameter is not a symbol or cons: ~S"
224 (values required optional restp rest keyp keys allowp auxp aux
225 morep more-context more-count key-object
)))