1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
12 (/show0
"parse-lambda-list.lisp 12")
14 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
15 (defconstant-eqx lambda-list-parser-states
16 #(:required
&optional
&rest
&more
&key
&aux
&environment
&whole
17 &allow-other-keys
&body
:post-env
:post-rest
:post-more
)
20 ;; Return a bitmask representing the LIST of lambda list keywords.
21 (defmacro lambda-list-keyword-mask
(list)
23 ;; When invoked with a quoted constant, some flexibility
24 ;; is allowed, in that the input may be a single symbol.
25 (let ((val (#+sb-xc constant-form-value
#-sb-xc eval list
)))
26 (loop for symbol in
(cond ((eq val
'destructuring-bind
)
27 '(&whole
&optional
&rest
&body
28 &key
&allow-other-keys
&aux
))
29 ((and val
(symbolp val
)) (list val
))
31 sum
(ash 1 (position symbol lambda-list-parser-states
))))
32 ;; Otherwise the input is required to be a list of symbols.
33 (with-unique-names (k)
34 `(loop for
,k in
,list
35 sum
(ash 1 (position ,k lambda-list-parser-states
))))))
37 (defun ll-kwds-restp (bits)
38 (when (logtest (lambda-list-keyword-mask '(&rest
&body
&more
)) bits
)
39 ;; Test &BODY first because if present, &REST bit is also set.
40 (cond ((logtest (lambda-list-keyword-mask '&body
) bits
) '&body
)
41 ((logtest (lambda-list-keyword-mask '&more
) bits
) '&more
)
44 ;;; Some accessors to distinguish a parse of (values &optional) from (values)
45 ;;; and (lambda (x &key)) from (lambda (x)).
46 (declaim (inline ll-kwds-keyp ll-kwds-allowp
))
47 (defun ll-kwds-keyp (bits)
48 (logtest (lambda-list-keyword-mask '&key
) bits
))
49 (defun ll-kwds-allowp (bits)
50 (logtest (lambda-list-keyword-mask '&allow-other-keys
) bits
))
52 ;;; Break something like a lambda list (but not necessarily actually a
53 ;;; lambda list, e.g. the representation of argument types which is
54 ;;; used within an FTYPE specification) into its component parts. We
55 ;;; return eight values:
56 ;;; 1. a bitmask of lambda-list keywords which were present;
57 ;;; 2. a list of the required args;
58 ;;; 3. a list of the &OPTIONAL arg specs;
59 ;;; 4. a singleton list of the &REST arg if present;
60 ;;; or a 2-list of the &MORE context and count if present
61 ;;; 5. a list of the &KEY arg specs;
62 ;;; 6. a list of the &AUX specifiers;
63 ;;; 7. a singleton list of the &ENVIRONMENT arg if present
64 ;;; 8. a singleton list of the &WHOLE arg if present
66 ;;; The top level lambda list syntax is checked for validity, but the
67 ;;; arg specifiers are just passed through untouched. If something is
68 ;;; wrong, we use COMPILER-ERROR, aborting compilation to the last
70 (declaim (ftype (sfunction
71 (list &key
(:context t
) (:accept integer
) (:silent boolean
)
72 (:condition-class symbol
))
73 (values (unsigned-byte 13) list list list list list list list
))
76 ;;; Note: CLHS 3.4.4 [macro lambda list] allows &ENVIRONMENT anywhere,
77 ;;; but 3.4.7 [defsetf lambda list] has it only at the end.
78 ;;; This is possibly surprising to people since there seems to be some
79 ;;; expectation that a DEFSETF lambda list is a macro lambda list,
80 ;;; which it isn't. We'll relax and accept &ENVIRONMENT in the middle.
82 (defun parse-lambda-list
83 (list &key
(context "an ordinary lambda list")
84 (accept (lambda-list-keyword-mask
85 '(&optional
&rest
&more
&key
&allow-other-keys
&aux
)))
86 (condition-class 'simple-program-error
)
87 ;; For internal method functions, just shut up about everything
88 ;; that we could style-warn about. Interpreters tend to scan the
89 ;; lambda list at various inopportune times depending on strategy
90 ;; (macro caching, etc) and it's really annoying to see the
91 ;; &OPTIONAL/&KEY message randomly repeated, especially if it's
92 ;; someone else's code. Fwiw, 'full-eval' muffles warnings during
93 ;; all calls to this parser anyway.
94 (silent (typep list
'(cons (eql sb
!pcl
::.pv.
))))
95 &aux
(seen 0) required optional rest more keys aux env whole tail
97 (declare (optimize speed
))
98 (declare (type (unsigned-byte 13) accept seen
) (type (mod 4) rest-bits
))
99 (macrolet ((state (name)
100 (position (the symbol name
) lambda-list-parser-states
))
101 (state= (x y
) `(= ,x
(state ,y
)))
102 (bits (&rest list
) `(lambda-list-keyword-mask ',list
))
104 (declare (optimize (speed 0))) ; suppress generic math notes
107 for s in
'(required optional rest more
109 collect
`(,i
(setq ,s
,val
))))))
110 (labels ((destructuring-p ()
111 (logtest (bits &whole
) accept
))
112 (probably-ll-keyword-p (arg)
113 ;; Compiler doesn't see that the check is manually done. :-(
115 (declare (optimize (sb!c
::insert-array-bounds-checks
0)))
117 (let ((name (symbol-name arg
)))
118 (and (plusp (length name
))
119 (char= (char name
0) #\
&)))))
120 (check-suspicious (kind form
)
121 (and (probably-ll-keyword-p form
)
122 (member form sb
!xc
:lambda-list-keywords
)
123 (report-suspicious kind form
)))
124 (report-suspicious (kind what
)
125 (style-warn-once list
"suspicious ~A ~S in lambda list: ~S."
127 nil
) ; Avoid "return convention is not fixed" optimizer note
129 (croak "expecting variable after ~A in: ~S" state list
))
132 (croak "~A is not a symbol: ~S" why x
)))
133 (need-bindable (x why
)
134 ;; "Bindable" means symbol or cons, but only if destructuring.
135 (unless (or (symbolp x
) (and (consp x
) (destructuring-p)))
136 (if (destructuring-p)
137 (croak "~A is not a symbol or list: ~S" why x
)
138 (croak "~A is not a symbol: ~S" why x
))))
139 (defaultp (x what-kind
)
140 (cond ((symbolp x
) nil
)
142 (t (croak "~A parameter is not a symbol or cons: ~S"
144 (croak (string &optional
(a1 0 a1p
) (a2 0 a2p
) (a3 0 a3p
))
145 ;; Don't care that FUNCALL can't elide fdefinition here.
146 (declare (optimize (speed 1)))
147 (let ((l (if a1p
(list a1 a2 a3
))))
148 (if (and l
(not a3p
)) (rplacd (if a2p
(cdr l
) l
) nil
))
149 ;; KLUDGE: When this function was limited to parsing
150 ;; ordinary lambda lists, this error call was always
151 ;; COMPILER-ERROR, which must be used, not plain old ERROR,
152 ;; to avoid the compiler itself crashing. But outside of
153 ;; the compiler, it must be ERROR. This discrepancy is sad
154 ;; since DESTRUCTURING-BIND herein can cause a compiler crash.
155 ;; It seems that the right thing is for the compiler to wrap
156 ;; a condition handler around PARSE-LAMBDA-LIST.
157 ;; Expecting a callee to understand how to signal conditions
158 ;; tailored to a particular caller is not how things are
160 (funcall (if (or (destructuring-p) (eq context
'defmethod
))
164 :format-control string
:format-arguments l
))))
167 (state (state :required
))
170 (declare (type (mod 13) state saved-state
))
174 (if (logbitp state
(bits &whole
&rest
&more
&environment
))
176 ;; Whenever &BODY is accepted, so is a dotted tail.
177 ((and (logtest (bits &body
) accept
)
178 (not (logtest (bits &rest
&key
&aux
) seen
))
180 (setf rest
(list input
)))
182 (croak "illegal dotted lambda list: ~S" list
)))
184 (shiftf last-arg arg
(pop input
))
186 (when (probably-ll-keyword-p arg
)
187 ;; Handle a probable lambda list keyword
188 (multiple-value-bind (from-states to-state
)
190 (&optional
(values (bits :required
) (state &optional
)))
191 (&rest
(values (bits :required
&optional
) (state &rest
)))
192 (&more
(values (bits :required
&optional
) (state &more
)))
193 (&key
(values (bits :required
&optional
:post-rest
:post-more
)
195 (&allow-other-keys
(values (bits &key
) (state &allow-other-keys
)))
196 (&aux
(values (bits :post-more
:required
&optional
:post-rest
197 &key
&allow-other-keys
) (state &aux
)))
199 (setq saved-state state
)
200 (values (bits :required
&optional
:post-rest
&key
201 &allow-other-keys
&aux
) (state &environment
)))
202 ;; If &BODY is accepted, then it is folded into &REST state,
203 ;; but if it should be rejected, then it gets its own bit.
204 ;; Error message production is thereby confined to one spot.
205 (&body
(values (bits :required
&optional
)
206 (if (logtest (bits &body
) accept
)
207 (state &rest
) (state &body
))))
209 (values (if (and (state= state
:required
) (not required
)
210 (not (logtest (bits &environment
) seen
)))
214 (unless (logbitp to-state accept
)
215 (let ((where ; Keyword never legal in this flavor lambda list.
217 (:function-type
"a FUNCTION type specifier")
218 (:values-type
"a VALUES type specifier")
219 (:macro
"a macro lambda list")
220 (destructuring-bind "a destructuring lambda list")
221 (defmethod "a specialized lambda list")
223 (croak "~A is not allowed in ~A: ~S" arg where list
)))
225 ;; &ENVIRONMENT can't intercede between &KEY,&ALLOW-OTHER-KEYS.
226 ;; For all other cases it's as if &ENVIRONMENT were never there.
227 (when (and (state= state
:post-env
)
228 (not (state= saved-state
&key
)))
229 (shiftf state saved-state
0)) ; pop the state
231 (when (state= to-state
&rest
) ; store a disambiguation bit
232 (setq rest-bits
(logior rest-bits
(if (eq arg
'&body
) 1 2))))
234 ;; Try to avoid using the imprecise "Misplaced" message if
235 ;; a better thing can be said, e.g. &WHOLE must go to the front.
236 (cond ((logbitp to-state seen
) ; Oops! Been here before.
238 (croak "~S and ~S are mutually exclusive: ~S"
240 (croak "repeated ~S in lambda list: ~S" arg list
)))
241 ((logbitp state from-states
) ; valid transition
243 seen
(logior seen
(ash 1 state
))
244 tail nil
)) ; Reset the accumulator.
245 ((logbitp state
(bits &whole
&rest
&more
&environment
))
246 (need-arg last-arg
)) ; Variable expected.
248 (croak (if (state= to-state
&whole
)
249 "~A must appear first in a lambda list: ~S"
250 "misplaced ~A in lambda list: ~S")
253 ;; Fell through, so warn if desired, and fall through some more.
254 (unless silent
(report-suspicious "variable" arg
)))
256 ;; Handle a lambda variable
257 (when (logbitp state
(bits &allow-other-keys
; Not a collecting state.
258 :post-env
:post-rest
:post-more
))
259 (croak "expected lambda list keyword at ~S in: ~S" arg list
))
260 (let ((item (list arg
)))
261 (setq tail
(if tail
(setf (cdr tail
) item
) (begin-list item
))))
262 (when (logbitp state
(bits &rest
&more
&whole
&environment
))
263 (let ((next (cond ((state= state
&rest
) (state :post-rest
))
264 ((state= state
&whole
) (state :required
))
265 ((state= state
&more
) ; Should consume 2 symbols
266 (if (cdr more
) (state :post-more
)))
267 ;; Current state must be &ENVIRONMENT
268 ((and (state= saved-state
:required
) (not required
))
269 (state :required
)) ; Back to start state
271 (state :post-env
))))) ; Need a lambda-list-keyword
272 (when next
; Advance to new state.
273 (setq state next tail nil
))))
276 #-sb-xc-host
;; Supress &OPTIONAL + &KEY syle-warning on xc host
277 (when (and (logtest (bits &key
) seen
) optional
(not silent
))
278 ;; FIXME: add a condition class for this
280 list
"&OPTIONAL and &KEY found in the same lambda list: ~S" list
))
282 ;; For CONTEXT other than :VALUES-TYPE/:FUNCTION-TYPE we reject
283 ;; illegal list elements. Type specifiers have arbitrary shapes,
284 ;; such as (VALUES (ARRAY (MUMBLE) (1 2)) &OPTIONAL (MEMBER X Y Z)).
285 ;; But why don't we reject constant symbols here?
286 (unless (member context
'(:values-type
:function-type
))
288 ;; Refer to the comment above the :destructuring-whole test
289 ;; in lambda-list.pure as to why &WHOLE has two personalities.
290 (funcall (if (logtest (bits &environment
) accept
)
291 #'need-symbol
#'need-bindable
)
292 (car whole
) "&WHOLE argument"))
293 (dolist (arg required
)
294 (if (eq context
'defmethod
)
295 (unless (or (and (symbolp arg
) (not (null arg
)))
296 (and (listp arg
) (singleton-p (cdr arg
))))
297 (croak "arg is not a non-NIL symbol or a list of two elements: ~A"
299 (need-bindable arg
"Required argument")))
300 ;; FIXME: why not check symbol-ness of supplied-p variables now?
301 (flet ((scan-opt/key
(list what-kind description
)
303 (when (defaultp arg what-kind
)
304 ;; FIXME: (DEFUN F (&OPTIONAL (A B C D)) 42) crashes the
305 ;; compiler, but not as consequence of the new parser.
306 ;; (This is not a regression)
307 (destructuring-bind (var &optional default sup-p
) arg
308 (if (and (consp var
) (eq what-kind
'&key
))
309 (destructuring-bind (keyword-name var
) var
310 (unless (symbolp keyword-name
)
311 (croak "keyword-name in ~S is not a symbol" arg
))
312 (need-bindable var description
))
313 (need-bindable var description
))
314 ;; Inform the user about a possibly malformed
315 ;; destructuring list (&OPTIONAL (A &OPTIONAL B)).
316 ;; It's technically legal but unlikely to be right,
317 ;; as A's default form is the symbol &OPTIONAL,
318 ;; which is an unlikely name for a local variable,
319 ;; and an illegal name for a DEFVAR or such,
320 ;; being in the CL package.
322 (check-suspicious "default" default
)
323 (check-suspicious "supplied-p variable" sup-p
)))))))
324 (scan-opt/key optional
'&optional
"&OPTIONAL parameter name")
326 (need-bindable (car rest
) "&REST argument"))
327 (scan-opt/key keys
'&key
"&KEY parameter name")
329 (when (defaultp arg
'&aux
)
330 ;; FIXME: also potentially compiler-crash-inducing
331 (destructuring-bind (var &optional init-form
) arg
332 (declare (ignore init-form
))
333 ;; &AUX is not destructured
334 (need-symbol var
"&AUX parameter name"))))))
337 (values (logior seen
(if (oddp rest-bits
) (bits &body
) 0))
338 required optional
(or rest more
) keys aux env whole
))))
340 ;;; Construct an abstract representation of a destructuring lambda list
341 ;;; from its source form, recursing as necessary.
342 ;;; Warn if it looks like a default expression will cause pattern mismatch.
343 ;;; There are other things we could issue style warnings about:
344 ;;; - a &REST arg that destructures preceded by any optional args.
345 ;;; It's suspicious because if &REST destructures, then in essence it
346 ;;; must not be NIL, which means the optionals aren't really optional.
347 (defun parse-ds-lambda-list (lambda-list
349 (condition-class 'simple-program-error
))
350 (multiple-value-bind (llks required optional rest keys aux env whole
)
351 (parse-lambda-list lambda-list
352 :accept
(lambda-list-keyword-mask 'destructuring-bind
)
353 :context
'destructuring-bind
354 :silent silent
:condition-class condition-class
)
355 (declare (ignore env
) (notinline mapcar
))
356 (labels ((parse (list)
357 (if (atom list
) list
(parse-ds-lambda-list list
:silent silent
)))
358 (parse* (list arg-specifier
)
359 (let ((parse (parse list
)))
360 (when (and (not silent
) (vectorp parse
)) ; is destructuring
361 (let ((default (and (cdr arg-specifier
) ; have an explicit default
362 (cadr arg-specifier
))))
363 (when (and (constantp default
)
364 (not (ds-lambda-list-match-p
365 (#+sb-xc constant-form-value
#-sb-xc eval
367 (meta-abstractify-ds-lambda-list parse
))))
369 "Default expression ~S does not match ~S in ~S"
370 default list lambda-list
))))
373 (mapcar #'parse whole
) ; a singleton or NIL
374 (mapcar #'parse required
)
376 (if (atom x
) x
(cons (parse* (car x
) x
) (cdr x
))))
378 (mapcar #'parse rest
) ; a singleton or NIL
380 (if (typep x
'(cons cons
))
381 (cons (list (caar x
) (parse* (cadar x
) x
)) (cdr x
))
386 ;; Bind the parts of the abstract representation of a destructuring
387 ;; lambda list, a (SIMPLE-VECTOR 7), to individual symbols.
388 (defmacro with-ds-lambda-list-parts
((&rest parts-names
) parts
&body body
)
389 (aver (<= 1 (length parts-names
) 7))
390 (once-only ((parts `(the (simple-vector 7) ,parts
)))
391 `(let ,(loop for i from
0 for sym in parts-names
392 when sym collect
`(,sym
(svref ,parts
,i
)))
395 ;;; Split an optional argument specifier into the bound variable
396 ;;; or destructuring pattern, the default, and supplied-p var.
397 ;;; If present the supplied-p var is in a singleton list.
398 ;;; DEFAULT should be specified as '* when parsing a DEFTYPE lambda-list.
399 (defun parse-optional-arg-spec (spec &optional default
)
401 (symbol (values spec default nil
))
402 (cons (values (car spec
)
403 (if (cdr spec
) (cadr spec
) default
)
406 ;;; Split a keyword argument specifier into the keyword, the bound variable
407 ;;; or destructuring pattern, the default, and supplied-p var.
408 ;;; If present the supplied-p var is in a singleton list.
409 ;;; DEFAULT should be specified as '* when parsing a DEFTYPE lambda-list.
410 (defun parse-key-arg-spec (spec &optional default
)
412 (symbol (values (keywordicate spec
) spec default nil
))
413 (cons (destructuring-bind (var &optional
(def default
) . sup-p-var
) spec
415 (values (keywordicate var
) var def sup-p-var
)
416 (values (car var
) (cadr var
) def sup-p-var
))))))
418 ;;; Return a "twice abstracted" representation of DS-LAMBDA-LIST that removes
419 ;;; all variable names, &AUX parameters, supplied-p variables, and defaults.
420 ;;; The result is a list with trailing suffixes of NIL dropped, and which can
421 ;;; be given to an AST matcher yielding a boolean answer as to whether some
422 ;;; input matches, with one caveat: Destructured &OPTIONAL or &KEY default
423 ;;; forms may cause failure of a destructuring-bind due to inner expressions
424 ;;; causing mismatch. In most cases this can not be anticipated.
425 (defun meta-abstractify-ds-lambda-list (parsed-ds-lambda-list)
426 (labels ((process-opt/key
(x) (recurse (if (listp x
) (car x
) x
)))
428 (when (symbolp thing
)
429 (return-from recurse t
))
430 (with-ds-lambda-list-parts (llks whole req opt rest keys
) thing
432 (when (ll-kwds-keyp llks
)
433 (cons (ll-kwds-allowp llks
)
435 (cons (parse-key-arg-spec x
)
436 (if (typep x
'(cons cons
))
438 (process-opt/key x
))))
440 ;; Compute reversed representation of req, opt, rest.
441 (repr (list (when rest
(recurse (car rest
)))
442 (mapcar #'process-opt
/key opt
)
443 (mapcar #'recurse req
))))
444 ;; If &KEYS are present, then req, opt, rest must be too.
445 ;; But if not, then pop leading NILs (which become trailing
446 ;; NILs). Missing parts aren't stored.
447 ;; A degenerate ds-lambda-list accepting 0 args is just ().
449 (loop (if (or (null repr
) (car repr
)) (return) (pop repr
))))
450 (let ((result (nreconc repr keys
))
452 (if (vectorp whole
) ; Destructuring. Ugh.
453 ;; The input must match two things - a tree implied by
454 ;; the nested &WHOLE, and a tree that contains it.
455 `(:both
,(recurse whole
) ,@result
)
457 (recurse parsed-ds-lambda-list
)))
459 ;; Construct a lambda list from sublists.
460 ;; If &WHOLE and REST are present, they must be singleton lists.
461 ;; Any sublists that were obtained by parsing a destructuring
462 ;; lambda list must be supplied in their unparsed form.
463 (defun make-lambda-list (llks whole required
&optional optional rest keys aux
)
464 (append (when whole
(cons '&whole whole
))
466 (when (logtest (lambda-list-keyword-mask '&optional
) llks
)
467 (cons '&optional optional
))
468 (let ((restp (ll-kwds-restp llks
)))
469 (if (and rest
(not restp
)) ; lambda list was "dotted"
472 (when rest
(cons restp rest
))
473 (if (ll-kwds-keyp llks
) (cons '&key keys
)) ; KEYS can be nil
474 (if (ll-kwds-allowp llks
) '(&allow-other-keys
))
475 ;; Should &AUX be inserted even if empty? Probably not.
476 (if aux
(cons '&aux aux
)))))))
478 ;;; Produce a destructuring lambda list from its internalized representation,
479 ;;; excluding any parts that don't constrain the shape of the expected input.
480 ;;; &AUX, supplied-p vars, and defaults do not impose shape constraints.
482 ;;; However as a special case, some constant defaults are retained mainly for
483 ;;; backward-compatibility.
484 ;;; The reason for it is that a test in SB-INTROSPECT checks the lambda list
485 ;;; of type ARRAY, which has explicit '* defaults. They're explicit
486 ;;; because of a bug or deficiency in !DEF-TYPE-TRANSLATOR which does not
487 ;;; adhere to the convention that DEFTYPE-like lambda lists use '* as implicit
488 ;;; defaults for everything unless stated otherwise.
489 ;;; So really the '* should have been superfluous in the lambda list,
490 ;;; but I'm also not convinced that changing the test case is the right thing.
492 (defun unparse-ds-lambda-list (parsed-lambda-list &optional cache
)
493 (cond ((symbolp parsed-lambda-list
) parsed-lambda-list
)
494 ((cdr (assq parsed-lambda-list
(cdr cache
))))
496 (with-ds-lambda-list-parts (llks whole req optional rest keys
)
498 (labels ((process-opt (spec)
501 (cons (recurse (car spec
)) (maybe-default spec
))))
502 (maybe-default (spec)
503 (let ((def (cdr spec
)))
504 (when (and def
(typep (car def
)
505 '(or (cons (eql quote
))
508 (list (car def
))))) ; Remove any supplied-p var.
509 (recurse (x) (unparse-ds-lambda-list x cache
))
510 (memoize (input output
)
511 (when cache
(push (cons input output
) (cdr cache
)))
517 ;; &WHOLE is omitted unless it destructures something.
518 (when (vectorp (car whole
)) (list (recurse (car whole
))))
519 (mapcar #'recurse req
)
520 (mapcar #'process-opt optional
)
521 (when rest
(list (recurse (car rest
))))
523 (if (typep x
'(cons cons
))
524 (cons (list (caar x
) (recurse (cadar x
)))
529 ;;; Return the list of variables bound by a destructuring lambda list.
530 ;;; One purpose for this is to help expand destructuring-bind using
531 ;;; a strategy that delivers values to an MV-BIND.
532 ;;; It would otherwise be difficult to wrap a condition handler
533 ;;; around only the binding creation forms and not the body
534 ;;; of the destructuring-bind. Consider e.g.
536 (DESTRUCTURING-BIND (A &OPTIONAL
(B 0) (C 'DEF
)) L
(DOER))
537 -
> (multiple-value-bind (a b c
)
538 (handler-bind ((error (lambda (c) (return-from somewhere
))))
539 (values (pop (the cons L
))
541 (cond ((endp L
) 'def
)
542 ((endp (cdr L
)) (car L
))
543 (t (error "Excess args")))))
546 (defun ds-lambda-list-variables (parsed-lambda-list &optional
(include-aux t
))
548 (labels ((recurse (x) (if (vectorp x
) (scan x
) (output x
)))
549 (copy (x) (dolist (elt x
) (recurse elt
)))
550 (suppliedp-var (spec) (if (cddr spec
) (output (third spec
))))
552 (with-ds-lambda-list-parts (nil whole req opt rest key aux
) parts
556 (cond ((symbolp x
) (output x
))
561 (cond ((symbolp x
) (output x
))
562 (t (let ((k (car x
)))
563 (if (symbolp k
) (output k
) (recurse (cadr k
)))
564 (suppliedp-var x
)))))
567 (output (if (symbolp x
) x
(car x
))))))))
568 (recurse parsed-lambda-list
)
571 ;;; Return T if OBJECT matches TEMPLATE, where TEMPLATE is a meta-abstractified
572 ;;; destructuring lambda list. Mnemonic: the arguments are like TYPEP.
573 ;;; [Indeed the AST could be a monstrous type specifier involving {CONS,AND,OR}
574 ;;; except for lambda lists that involve keywords.]
576 (defun ds-lambda-list-match-p (object template
)
577 (macrolet ((pop-template () '(pop (truly-the list template
)))
579 '(unless template
(return-from recurse
(null args
))))
581 '(return-from recurse nil
)))
582 ;; When a failure occurs, we could return all the way out, but that would
583 ;; mean establishing a dynamic exit. Instead let failure bubble up.
584 (labels ((recurse (template args
)
585 (accept) ; Exit if no required, optional, rest, key args.
586 (when (eq (car (truly-the list template
)) :both
)
588 (and (recurse (cadr template
) args
)
589 (recurse (cddr template
) args
))))
591 (dolist (subpat (pop-template)) ; For each required argument
592 (let ((arg (if (atom args
) (fail) (pop args
))))
593 (when (and (listp subpat
) (not (recurse subpat arg
)))
595 (accept) ; Exit if no optional, rest, key args.
597 (dolist (subpat (pop-template))
598 (let ((arg (cond ((not (listp args
)) (fail))
600 ;; Why not just return T now?
601 ;; Because destructured &REST maybe.
604 (return-from recurse t
)))
606 (when (and (listp subpat
) (not (recurse subpat arg
)))
608 (accept) ; Exit if no rest, key args.
609 ;; If REST is not a cons, that's fine - it's either T, meaning
610 ;; that it was present but not a pattern, or NIL, meaning
611 ;; absent, in which case &KEY must have been present,
612 ;; otherwise the preceding (ACCEPT) would have returned.
613 (let ((rest (pop-template)))
614 (when (and (consp rest
) (not (recurse rest args
)))
616 (when (null template
) ; No keys.
617 (return-from recurse t
))
618 ;; Now test all keywords against the allowed ones, even if
619 ;; &ALLOW-OTHER-KEYS was present. Any key's value might bind
620 ;; to a subpattern, and the lambda list could be insane as well:
621 ;; (&KEY ((:allow-other-keys (x)) '(foo)))
622 ;; where the value of :ALLOW-OTHER-KEYS must apparently
624 (prog ((allowp (if (pop template
) t
0)) seen-other
)
627 (return (or (not seen-other
) (eq allowp t
))))
628 (unless (listp args
) (return nil
))
629 (let* ((next (cdr args
))
631 (cell (assq key template
)))
632 (unless (consp next
) (return nil
))
635 (let ((pattern (cdr cell
)))
636 (when (and (listp pattern
)
637 (not (recurse pattern
(car next
))))
639 (when (and (eq key
:allow-other-keys
) (eql allowp
0))
640 (setq allowp
(if (car next
) t nil
)))
641 (setq args
(cdr next
)))
643 (recurse template object
))))
645 ;;; Return the AST that recognizes inputs matching DS-LAMBDA-LIST.
646 (defun ds-lambda-list-matcher (ds-lambda-list)
647 (meta-abstractify-ds-lambda-list (parse-ds-lambda-list ds-lambda-list
)))
649 ;;; Emit a form to test whether INPUT matches DS-LAMBDA-LIST.
650 ;;; It's up to this function to decide (perhaps based on policy)
651 ;;; how to generate the code. There are a few simple cases that avoid
652 ;;; function calls. Others could easily be added. e.g. a 2-list could be:
653 ;;; (TYPEP INPUT '(CONS T (CONS T NULL)))
654 (defun emit-ds-lambda-list-match (input ds-lambda-list
)
655 (let ((matcher (ds-lambda-list-matcher ds-lambda-list
)))
656 ;; To match exactly 1 required arg, use SINGLETON-P.
657 (cond ((equal matcher
'((t))) `(singleton-p ,input
))
658 ;; Matching 0 required, 0 optional, and rest is trivially T.
659 ((equal matcher
'(() () t
)) t
)
660 (t `(ds-lambda-list-match-p ,input
',matcher
)))))
662 ;;; Emit a correctness check for one level of structure in PARSED-LAMBDA-LIST
663 ;;; which receives values from INPUT.
664 ;;; MACRO-CONTEXT provides context for the diagnostic message.
665 ;;; MEMO-TABLE is an alist of previously-unparsed parsed-lambda-lists.
666 ;;; The checker returns INPUT if it was well-formed, or signals an error.
668 ;;; There is a better way (not implemented) to check &KEY arguments: assume
669 ;;; optimistically that unknown/duplicate keywords aren't frequent, and perform
670 ;;; all GETF operations for known keywords into temp vars; count the ones that
671 ;;; found something, and compare to the plist length/2. If not equal, then do
672 ;;; a further check. Otherwise we've done most of the work of parsing;
673 ;;; just move the temps into their final places in turn.
675 (defun emit-ds-bind-check (parsed-lambda-list input macro-context memo-table
)
676 (with-ds-lambda-list-parts (llks nil req opt rest keys
) parsed-lambda-list
677 (let* ((display (unparse-ds-lambda-list parsed-lambda-list memo-table
))
678 (pattern `',(if macro-context
(cons macro-context display
) display
))
680 (max (+ min
(length opt
)))
681 (bounds (list min max
)))
682 (cond ((ll-kwds-keyp llks
)
683 `(,(if (eq (cddr macro-context
) 'define-compiler-macro
)
684 'cmacro-check-ds-list
/&key
686 ,input
,@bounds
,pattern
687 ,(unless (ll-kwds-allowp llks
)
688 (map 'vector
#'parse-key-arg-spec keys
))))
689 ;; The case that need not check anything at all:
690 ;; no keys, no required, no optional, and a &rest arg.
691 ((and rest
(eql max
0)) input
) ; nothing to check
692 (rest `(check-ds-list/&rest
,input
,@bounds
,pattern
))
693 (t `(check-ds-list ,input
,@bounds
,pattern
))))))
695 ;;; Produce the binding clauses for a BINDING* form that destructures
696 ;;; LAMBDA-LIST from input in DATA.
697 ;;; EMIT-PRE-TEST, if true, will diagnose most (but not all) structural
698 ;;; errors [*] before executing user-supplied code in defaulting forms.
699 ;;; EXPLICIT-CAST is one of {THE, TRULY-THE, NIL} to insert casts or not.
700 ;;; Optional MACRO-CONTEXT provides context for the error strings.
701 ;;; DEFAULT-DEFAULT, which defaults to NIL, supplies the value for optional
702 ;;; and key arguments which were absent and had no explicit defaulting form.
704 ;;; Without explicit casts, the input must satisfy LISTP at each CAR/CDR step.
705 ;;; If pre-tests were done and user code did not smash the input, then it
706 ;;; will satisfy LISTP, and EXPLICIT-CAST may be specified as 'TRULY-THE
707 ;;; to omit compiler-generated ("checkgen") tests. If pre-tests were not done,
708 ;;; then EXPLICIT-CAST should be specified as 'THE to strengthen type tests
709 ;;; into (THE CONS x) at mandatory arguments.
711 ;;; [*] "Structural errors" are those due to mismatch of the input against
712 ;;; the template; in the case of one list level, an error can be signaled
713 ;;; before defaults are evaluated, but with nested destructuring, this is not
714 ;;; always possible. Previously there was an attempt to check outer lists
715 ;;; before proceeding to inner lists, but this required departure from
716 ;;; customary left-to-right evaluation order of source forms as written.
717 ;;; The new scheme seems more in accordance with other Lisp implementations.
718 ;;; Portable code should probably not rely on the order in which structural
719 ;;; errors are tested for. If input is well-formed - it matches the template -
720 ;;; then there is no possibility of user code sensing the order in which
721 ;;; well-formedness tests ran.
723 (defun expand-ds-bind (lambda-list data emit-pre-test explicit-cast
724 &optional macro-context default-default
)
725 (collect ((cache (list nil
)) ; This is a "scratchpad" for the unparser.
728 (;; Bind VAR from VAL-FORM. VAR can be a symbol or ds-lambda-list.
729 (bind-pat (var val-form
)
730 (if (symbolp var
) (bind `(,var
,val-form
)) (descend var val-form
)))
731 ;; Conditionally bind VAR from VAL-FORM based on SUP-P-FORM.
732 (bind-if (sense sup-p-form val-form var sup-p-var def
)
733 (let* ((suppliedp (car sup-p-var
)) ; could be nil
734 (vals (gen-test sense sup-p-form
735 (if sup-p-var
`(values ,val-form t
) val-form
)
737 (cond ((not sup-p-var
) (bind-pat var vals
))
738 ((symbolp var
) (bind `((,var
,suppliedp
) ,vals
)))
740 (let ((var-temp (sb!xc
:gensym
))
741 (sup-p-temp (copy-symbol suppliedp
)))
742 (bind `((,var-temp
,sup-p-temp
) ,vals
))
743 (descend var var-temp
)
744 (bind `(,suppliedp
,sup-p-temp
)))))))
745 (gen-test (sense test then else
)
746 (cond ((eq sense t
) `(if ,test
,then
,@(if else
(list else
))))
747 (else `(if ,test
,else
,then
)) ; flip the branches
748 (t `(if (not ,test
) ,then
)))) ; invert the test
749 (descend (parsed-lambda-list input
)
750 (with-ds-lambda-list-parts (llks whole required opt rest keys aux
)
752 ;; There could be nothing but &AUX vars in the lambda list.
753 ;; If nothing to bind from INPUT, then ignore "ds-check" result.
754 ;; But if keywords are accepted, always call the checker.
755 ;; A feature of BINDING* is that binding something to () means,
756 ;; in theory, (MULTIPLE-VALUE-BIND () (EXPR) ...)
757 ;; but in practice it becomes a binding of an ignored gensym.
758 (let* ((bindings-p (or whole required opt rest keys
))
759 (temp (and bindings-p
(sb!xc
:gensym
))))
761 ,(cond ((or emit-pre-test
(ll-kwds-keyp llks
))
762 (emit-ds-bind-check parsed-lambda-list input
763 macro-context
(cache)))
764 ((or bindings-p
(not explicit-cast
)) input
)
765 ;; If nothing gets bound, then input must be NIL,
766 ;; unless &KEY is accepted, which was done above.
767 (t `(,explicit-cast null
,input
)))))
769 ;; I would think it totally absurd to use something
770 ;; other than a symbol for &WHOLE, but the spec allows it.
771 (when whole
(bind-pat (car whole
) input
))
773 (flet ((cast/pop
(typed-list-expr more-to-go
)
774 `(prog1 (car ,typed-list-expr
)
775 ,(if (or more-to-go rest
(ll-kwds-keyp llks
))
776 `(setq ,input
(cdr ,input
))
777 `(,explicit-cast null
(cdr ,input
))))))
778 ;; Mandatory args. Only the rightmost need check that it sees
779 ;; a CONS. The predecessors will naturally assert that the
780 ;; input so far was of type LIST, which is enough.
781 (do ((elts required
(cdr elts
)))
785 (cast/pop
`(,explicit-cast
786 ,(if (cdr elts
) 'list
'cons
) ,input
)
790 (do ((elts opt
(cdr elts
)))
792 (multiple-value-bind (var def sup-p-var
)
793 (parse-optional-arg-spec (car elts
) default-default
)
796 (cast/pop
`(,explicit-cast list
,input
)
799 var sup-p-var def
))))
801 ;; The spec allows the inane use of (A B &REST (C D)) = (A B C D).
802 ;; The former is less efficient, since it is "nested", only not.
803 (when rest
(bind-pat (car rest
) input
))
807 (multiple-value-bind (keyword var def sup-p-var
)
808 (parse-key-arg-spec elt default-default
)
809 (let ((temp (sb!xc
:gensym
)))
810 (bind `(,temp
(ds-getf ,input
',keyword
)))
811 (bind-if :not
`(eql ,temp
0) `(car (truly-the cons
,temp
))
812 var sup-p-var def
))))
814 ;; &AUX bindings aren't destructured. Finally something easy.
816 (multiple-value-bind (var val
)
817 (if (listp elt
) (values (car elt
) (cadr elt
)) elt
)
818 (bind `(,var
,val
)))))))
820 (descend (parse-ds-lambda-list lambda-list
) data
)
825 ;; Given FORM as the input to a compiler-macro, return the argument forms
826 ;; that the called function would receive, skipping over FUNCALL.
827 (defun compiler-macro-args (form)
828 (cdr (if (eql (car form
) 'funcall
) (cdr form
) form
)))
830 ;; Extract the context from a destructuring-bind pattern as represented in
831 ;; a call to a checking function. A "context" is a non-bindable subpattern
832 ;; headed by :MACRO (if it came from any macro-like thing, e.g. DEFTYPE),
834 ;; Return three values: CONTEXT-NAME, CONTEXT-KIND, and the real pattern.
835 (defun get-ds-bind-context (pattern)
836 (let ((marker (car pattern
)))
837 (case (and (listp marker
) (car marker
))
839 (let ((context (cdr marker
)))
840 (values (car context
) (cdr context
) (cdr pattern
))))
842 (values (cdr marker
) :special-form
(cdr pattern
)))
844 (values nil
:eval
(cdr pattern
)))
846 (values nil
'destructuring-bind pattern
)))))
848 ;;; Helpers for the variations on CHECK-DS-mumble.
849 (defun ds-bind-error (input min max pattern
)
850 (multiple-value-bind (name kind lambda-list
) (get-ds-bind-context pattern
)
852 (declare (optimize allow-non-returning-tail-call
))
855 ;; IR1 translators should call COMPILER-ERROR instead of
856 ;; ERROR. To ingrain that knowledge into the CHECK-DS-foo
857 ;; functions is a bit of a hack, but to do otherwise
858 ;; changes how DS-BIND has to expand.
859 (compiler-error 'sb
!kernel
::arg-count-error
860 :kind
"special operator" :name name
861 :args input
:lambda-list lambda-list
862 :minimum min
:maximum max
))
865 (error 'sb
!eval
::arg-count-program-error
866 ;; This is stupid. Maybe we should just say
867 ;; "error parsing special form"?
868 ;; It would be more sensible than mentioning
869 ;; a random nonstandard macro.
870 :kind
'sb
!eval
::program-destructuring-bind
871 :args input
:lambda-list lambda-list
872 :minimum min
:maximum max
))
874 (error 'sb
!kernel
::arg-count-error
875 :kind kind
:name name
876 :args input
:lambda-list lambda-list
877 :minimum min
:maximum max
)))))
879 (defun check-ds-bind-keys (input plist valid-keys pattern
)
880 ;; Check just the keyword portion of the input in PLIST
881 ;; against VALID-KEYS. If VALID-KEYS = NIL then we don't care what
882 ;; the keys are - &ALLOW-OTHER-KEYS was present in the lambda-list,
883 ;; and we don't care if non-symbols are found in keyword position.
884 ;; Always enforce that the list has even length though.
885 (let* (seen-allowp seen-other bad-key
891 (return :unknown-keyword
)
892 (return-from check-ds-bind-keys input
)))
893 (unless (listp tail
) (return :dotted-list
))
894 (let ((next (cdr tail
)))
895 (when (null next
) (return :odd-length
))
896 (unless (listp next
) (return :dotted-list
))
897 (let ((key (car tail
)))
899 (if (eq key
:allow-other-keys
) ; always itself allowed
902 (when (car next
) ; :allow-other-keys <non-nil>
903 (setf seen-other nil valid-keys nil
)))
904 (unless (or seen-other
905 (find key
(truly-the simple-vector valid-keys
)
907 (setq seen-other t bad-key key
)))))
908 (setq tail
(cdr next
))))))
909 (multiple-value-bind (kind name
) (get-ds-bind-context pattern
)
911 (declare (optimize allow-non-returning-tail-call
))
912 ;; KLUDGE: Compiling (COERCE x 'list) transforms to COERCE-TO-LIST,
913 ;; but COERCE-TO-LIST is an inline function not yet defined, and
914 ;; its subsequent definition would signal an inlining failure warning.
915 (declare (notinline coerce
))
916 (error 'sb
!kernel
::defmacro-lambda-list-broken-key-list-error
917 :kind kind
:name name
919 :info
(if (eq problem
:unknown-keyword
)
920 ;; show any one unaccepted keyword
921 (list bad-key
(coerce valid-keys
'list
))
924 (macrolet ((scan-req-opt ((input min max pattern list-name actual-max
)
925 &key if-list-exhausted if-max-reached
)
926 ;; Decide whether the input matches up to the end of
927 ;; the required and/or optional arguments.
928 ;; MAX is the limit on number of CDR operations performed
929 ;; in the loop. ACTUAL-MAX describes the upper bound
930 ;; in a condition reporting function.
931 ;; e.g. (A &OPTIONAL B &REST C) has MAX = 2, ACTUAL-MAX = NIL.
932 ;; The input must be a proper list up to 2 arguments,
933 ;; but beyond that may be dotted.
934 `(let ((,list-name
,input
) (count ,max
))
935 (declare (type index count
))
936 (loop (when (zerop count
) (return ,if-max-reached
))
937 (when (null ,list-name
)
939 (if (< (- max count
) ,min
)
940 (ds-bind-error ,input
,min
,actual-max
,pattern
)
941 ,if-list-exhausted
)))
942 (unless (listp ,list-name
) ; dotted list error
944 (ds-bind-error ,input
,min
,actual-max
,pattern
)))
946 (setq ,list-name
(cdr ,list-name
))))))
948 ;; Assert that INPUT has the requisite number of elements as
949 ;; specified by MIN/MAX. PATTERN does not contain &REST or &KEY.
950 (defun check-ds-list (input min max pattern
)
951 (declare (type index min max
) (optimize speed
))
952 (scan-req-opt (input min max pattern list max
)
953 ;; If 'count' became zero, then since there was
954 ;; no &REST, the LIST had better be NIL.
956 (if list
(ds-bind-error input min max pattern
) input
)
957 ;; The loop checks for dotted tail and >= MIN elements,
958 ;; so end of list means a valid match to the pattern.
959 :if-list-exhausted input
))
961 ;; As above, but the pattern contains &REST.
962 ;; Elements beyond the final optional arg can form a dotted list.
963 (defun check-ds-list/&rest
(input min max pattern
)
964 (declare (type index min max
) (optimize speed
))
965 (scan-req-opt (input min max pattern list nil
)
966 :if-list-exhausted input
:if-max-reached input
))
968 ;; The pattern contains &KEY. Anything beyond the final optional arg
969 ;; must be a well-formed property list regardless of existence of &REST.
970 (defun check-ds-list/&key
(input min max pattern valid-keys
)
971 (declare (type index min max
) (optimize speed
))
972 (scan-req-opt (input min max pattern list nil
)
973 :if-list-exhausted input
974 :if-max-reached
(check-ds-bind-keys
975 input list valid-keys pattern
)))
977 ;; Compiler-macro lambda lists are macro lambda lists -- meaning that
978 ;; &key ((a a) t) should match a literal A, not a form evaluating to A
979 ;; as in an ordinary lambda list.
981 ;; That, however, breaks the evaluation model unless A is also a
982 ;; constant evaluating to itself. So, signal a condition telling the
983 ;; compiler to punt on the expansion.
984 ;; Moreover it has to be assumed that any non-constant might
985 ;; evaluate to :ALLOW-OTHER-KEYS.
987 ;; The reason this is its own function is for separation of concerns.
988 ;; Suppose that CHECK-DS-LIST/&KEY had a short-circuit exit wherein
989 ;; seeing ":ALLOW-OTHER-KEYS <non-nil>" stopped testing for keywords in
990 ;; the accepted list, but instead quickly scanned for a proper tail.
991 ;; (It doesn't, but suppose it did). A compiler-macro must nonetheless
992 ;; finish looking for all non-constant symbols in keyword positions.
993 ;; More realistically, if the optimization for &KEY mentioned above
994 ;; EMIT-DS-BIND-CHECK were implemented, where perhaps we elide a call
995 ;; to validate keywords, a compiler-macro is probably always best
996 ;; handled by a out-of-line call on account of the extra hair.
998 (defun cmacro-check-ds-list/&key
(input min max pattern valid-keys
)
999 (declare (type index min max
) (optimize speed
))
1000 (scan-req-opt (input min max pattern list nil
)
1001 :if-list-exhausted input
1003 ;; Signal a condition if the compiler should give up
1004 ;; on expanding. Well-formedness of the plist
1005 ;; makes no difference, since CHECK-DS-BIND-KEYS is stricter.
1006 ;; If the condition isn't handled, we just press onward.
1008 (loop (when (atom plist
) (return))
1009 (let ((key (pop plist
)))
1010 (when (atom plist
) (return))
1012 (unless (or (keywordp key
)
1015 (eq key
(symbol-value key
))))
1016 (signal 'compiler-macro-keyword-problem
1018 (check-ds-bind-keys input list valid-keys pattern
)))))
1020 ;; Like GETF but return CDR of the cell whose CAR contained the found key,
1021 ;; instead of CADR; and return 0 for not found.
1022 ;; This helps destructuring-bind slightly by avoiding a secondary value as a
1023 ;; found/not-found indicator, and using 0 is better for backends which don't
1024 ;; wire a register to NIL. Also, NIL would accidentally allow taking its CAR
1025 ;; if the caller were to try, whereas we'd want to see a explicit error.
1026 (defun ds-getf (place indicator
)
1027 (do ((plist place
(cddr plist
)))
1029 (cond ((atom (cdr plist
))
1030 (error 'simple-type-error
1031 :format-control
"malformed property list: ~S."
1032 :format-arguments
(list place
)
1034 :expected-type
'cons
))
1035 ((eq (car plist
) indicator
)
1036 ;; Typecheck the next cell so that calling code doesn't get an atom.
1037 (return (the cons
(cdr plist
)))))))
1039 ;;; Make a lambda expression that receives an s-expression, destructures it
1040 ;;; according to LAMBDA-LIST, and executes BODY.
1041 ;;; NAME and KIND provide error-reporting context.
1042 ;;; DOC-STRING-ALLOWED can be :INTERNAL to allow a docstring which is kept
1043 ;;; inside the lambda, or :EXTERNAL to pull it out and return it, or NIL.
1044 ;;; ENVIRONMENT can be NIL to disallow an &ENVIRONMENT variable,
1045 ;;; or :IGNORE to allow it, but bind the corresponding symbol to NIL.
1046 ;;; WRAP-BLOCK, if true, will place a block named NAME around body.
1048 ;;; The secondary value is a docstring, if requested as :EXTERNAL.
1050 ;;; The lambda contains an internal declaration of its argument list
1051 ;;; that discards &ENVIRONMENT, &WHOLE, and/or anything else that does
1052 ;;; not document the expected list shape.
1054 ;;; The CLtl2 name for this operation is PARSE-MACRO.
1055 (defun make-macro-lambda
1056 (lambda-name lambda-list body kind name
1057 &key
(accessor 'cdr
) (doc-string-allowed :internal
)
1058 ((:environment envp
) t
) (wrap-block name
))
1059 (declare (type (member t nil
:ignore
) envp
))
1060 (declare (type (member nil
:external
:internal
) doc-string-allowed
))
1061 (binding* (((forms decls docstring
) (parse-body body doc-string-allowed
))
1062 ;; Parse the lambda list, but not recursively.
1063 ((llks req opt rest keys aux env whole
)
1067 (if envp
(lambda-list-keyword-mask '&environment
) 0)
1068 (lambda-list-keyword-mask 'destructuring-bind
))
1069 ;; Why :silent? We first parse to deconstruct and reconstruct
1070 ;; without &WHOLE and &ENV, which is an implementation detail.
1071 ;; When it comes to actually processing the entire lambda
1072 ;; list again, that's when any warning(s) will be issued.
1073 :context
:macro
:silent t
))
1074 ((outer-decls decls
) (extract-var-decls decls
(append env whole
)))
1075 (ll-env (when (eq envp t
) (or env
(list (make-symbol "ENV")))))
1076 ;; We want a hidden WHOLE arg for the lambda - not the user's -
1077 ;; in case one was present and declared IGNORE.
1078 ;; Conversely, if the user asks for &WHOLE, doesn't use it,
1079 ;; and doesn't declare it ignored, that deserves a warning.
1080 (ll-whole (make-symbol "EXPR"))
1081 ;; Then bind the user's WHOLE from the lambda's.
1083 (append (when (and (eq envp
:ignore
) env
) `((,(car env
) nil
)))
1084 (when whole
`((,(car whole
) ,ll-whole
)))))
1085 ;; Drop &WHOLE and &ENVIRONMENT
1086 (new-ll (make-lambda-list llks nil req opt rest keys aux
))
1087 (parse (parse-ds-lambda-list new-ll
)))
1088 ;; Signal a style warning for duplicate names, but disregard &AUX variables
1089 ;; because most folks agree that (LET* ((X (F)) (X (G X))) ..) makes sense
1090 ;; - some would even say that it is idiomatic - and &AUX bindings are just
1092 ;; The obsolete PARSE-DEFMACRO signaled an error, but that seems harsh.
1093 ;; Other implementations permit (X &OPTIONAL X),
1094 ;; and the allowance for nesting makes this issue even less clear.
1095 (mapl (lambda (tail)
1096 (when (memq (car tail
) (cdr tail
))
1097 (style-warn-once lambda-list
"variable ~S occurs more than once"
1099 (append whole env
(ds-lambda-list-variables parse nil
)))
1100 (values `(,@(if lambda-name
`(named-lambda ,lambda-name
) '(lambda))
1101 (,ll-whole
,@ll-env
,@(and ll-aux
(cons '&aux ll-aux
)))
1102 ,@(when (and docstring
(eq doc-string-allowed
:internal
))
1103 (prog1 (list docstring
) (setq docstring nil
)))
1104 ;; MACROLET doesn't produce an object capable of reflection,
1105 ;; so don't bother inserting a different lambda-list.
1106 ,@(unless (eq kind
'macrolet
)
1107 ;; Normalize the lambda list by unparsing.
1108 `((declare (lambda-list ,(unparse-ds-lambda-list parse
)))))
1109 ,@(if outer-decls
(list outer-decls
))
1110 ,@(and (not env
) (eq envp t
) `((declare (ignore ,@ll-env
))))
1111 ,@(sb!c
:macro-policy-decls
)
1113 `(named-ds-bind ,(if (eq kind
:special-form
)
1114 `(:special-form .
,name
)
1115 `(:macro
,name .
,kind
)))
1116 '(destructuring-bind))
1117 ,new-ll
(,accessor
,ll-whole
)
1120 `((block ,(fun-name-block-name name
) ,@forms
))
1124 ;;; Functions should probably not retain &AUX variables as part
1125 ;;; of their reflected lambda list, but this is selectable
1126 ;;; because some users might claim that dropping &AUX is wrong.
1127 ;;; For system code, it's a measurably large waste of space,
1128 ;;; given how DEFTRANSFORM and a few other macros expand such
1129 ;;; that argument parsing is performed in &AUX var initforms.
1130 (defvar *strip-lamba-list-retain-aux
* #+sb-xc t
#-sb-xc nil
)
1132 ;;; Return LAMBDA-LIST with some pieces removed.
1133 (defun strip-lambda-list (lambda-list how
)
1134 (handler-case (parse-lambda-list lambda-list
:silent t
)
1135 (error () lambda-list
)
1136 (:no-error
(llks req opt rest keys aux
&rest ignore
)
1137 (declare (ignore ignore
))
1138 (multiple-value-bind (opt keys aux
)
1141 (values opt keys
(if *strip-lamba-list-retain-aux
* aux nil
)))
1142 ;; The name of an anonymous lambda is an arbitrary list,
1143 ;; not necessarily the original list.
1144 (:name
(values (mapcar #'parse-optional-arg-spec opt
); Keep name.
1145 (mapcar #'parse-key-arg-spec keys
) ; Keep keyword.
1146 nil
))) ; Discard &AUX vars
1147 (let ((new (make-lambda-list llks nil req opt rest keys aux
)))
1148 ;; It is harmful to the space-saving effect of this function
1149 ;; if reconstituting the list results in an unnecessary copy.
1150 (if (equal new lambda-list
) lambda-list new
))))))
1152 (/show0
"parse-lambda-list.lisp end of file")