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
)
88 &aux
(seen 0) required optional rest more keys aux env whole tail
90 (declare (optimize speed
))
91 (declare (type (unsigned-byte 13) accept seen
) (type (mod 4) rest-bits
))
92 (macrolet ((state (name)
93 (position (the symbol name
) lambda-list-parser-states
))
94 (state= (x y
) `(= ,x
(state ,y
)))
95 (bits (&rest list
) `(lambda-list-keyword-mask ',list
))
97 (declare (optimize (speed 0))) ; suppress generic math notes
100 for s in
'(required optional rest more
102 collect
`(,i
(setq ,s
,val
))))))
103 (labels ((destructuring-p ()
104 (logtest (bits &whole
) accept
))
105 (probably-ll-keyword-p (arg)
106 ;; Compiler doesn't see that the check is manually done. :-(
108 (declare (optimize (sb!c
::insert-array-bounds-checks
0)))
110 (let ((name (symbol-name arg
)))
111 (and (typep name
'simple-base-string
)
112 (plusp (length name
))
113 (char= (char name
0) #\
&)))))
114 (check-suspicious (kind form
)
115 (and (probably-ll-keyword-p form
)
116 (member form sb
!xc
:lambda-list-keywords
)
117 (report-suspicious kind form
)))
118 (report-suspicious (kind what
)
119 (style-warn "suspicious ~A ~S in lambda list: ~S."
121 nil
) ; Avoid "return convention is not fixed" optimizer note
123 (croak "expecting variable after ~A in: ~S" state list
))
126 (croak "~A is not a symbol: ~S" why x
)))
127 (need-bindable (x why
)
128 ;; "Bindable" means symbol or cons, but only if destructuring.
129 (unless (or (symbolp x
) (and (consp x
) (destructuring-p)))
130 (if (destructuring-p)
131 (croak "~A is not a symbol or list: ~S" why x
)
132 (croak "~A is not a symbol: ~S" why x
))))
133 (defaultp (x what-kind
)
134 (cond ((symbolp x
) nil
)
136 (t (croak "~A parameter is not a symbol or cons: ~S"
138 (croak (string &optional
(a1 0 a1p
) (a2 0 a2p
) (a3 0 a3p
))
139 ;; Don't care that FUNCALL can't elide fdefinition here.
140 (declare (optimize (speed 1)))
141 (let ((l (if a1p
(list a1 a2 a3
))))
142 (if (and l
(not a3p
)) (rplacd (if a2p
(cdr l
) l
) nil
))
143 ;; KLUDGE: When this function was limited to parsing
144 ;; ordinary lambda lists, this error call was always
145 ;; COMPILER-ERROR, which must be used, not plain old ERROR,
146 ;; to avoid the compiler itself crashing. But outside of
147 ;; the compiler, it must be ERROR. This discrepancy is sad
148 ;; since DESTRUCTURING-BIND herein can cause a compiler crash.
149 ;; It seems that the right thing is for the compiler to wrap
150 ;; a condition handler around PARSE-LAMBDA-LIST.
151 ;; Expecting a callee to understand how to signal conditions
152 ;; tailored to a particular caller is not how things are
154 (funcall (if (or (destructuring-p) (eq context
'defmethod
))
158 :format-control string
:format-arguments l
))))
161 (state (state :required
))
164 (declare (type (mod 13) state saved-state
))
168 (if (logbitp state
(bits &whole
&rest
&more
&environment
))
170 ;; Whenever &BODY is accepted, so is a dotted tail.
171 ((and (logtest (bits &body
) accept
)
172 (not (logtest (bits &rest
&key
&aux
) seen
))
174 (setf rest
(list input
)))
176 (croak "illegal dotted lambda list: ~S" list
)))
178 (shiftf last-arg arg
(pop input
))
180 (when (probably-ll-keyword-p arg
)
181 ;; Handle a probable lambda list keyword
182 (multiple-value-bind (from-states to-state
)
184 (&optional
(values (bits :required
) (state &optional
)))
185 (&rest
(values (bits :required
&optional
) (state &rest
)))
186 (&more
(values (bits :required
&optional
) (state &more
)))
187 (&key
(values (bits :required
&optional
:post-rest
:post-more
)
189 (&allow-other-keys
(values (bits &key
) (state &allow-other-keys
)))
190 (&aux
(values (bits :post-more
:required
&optional
:post-rest
191 &key
&allow-other-keys
) (state &aux
)))
193 (setq saved-state state
)
194 (values (bits :required
&optional
:post-rest
&key
195 &allow-other-keys
&aux
) (state &environment
)))
196 ;; If &BODY is accepted, then it is folded into &REST state,
197 ;; but if it should be rejected, then it gets its own bit.
198 ;; Error message production is thereby confined to one spot.
199 (&body
(values (bits :required
&optional
)
200 (if (logtest (bits &body
) accept
)
201 (state &rest
) (state &body
))))
203 (values (if (and (state= state
:required
) (not required
)
204 (not (logtest (bits &environment
) seen
)))
208 (unless (logbitp to-state accept
)
209 (let ((where ; Keyword never legal in this flavor lambda list.
211 (:function-type
"a FUNCTION type specifier")
212 (:values-type
"a VALUES type specifier")
213 (:macro
"a macro lambda list")
214 (destructuring-bind "a destructuring lambda list")
215 (defmethod "a specialized lambda list")
217 (croak "~A is not allowed in ~A: ~S" arg where list
)))
219 ;; &ENVIRONMENT can't intercede between &KEY,&ALLOW-OTHER-KEYS.
220 ;; For all other cases it's as if &ENVIRONMENT were never there.
221 (when (and (state= state
:post-env
)
222 (not (state= saved-state
&key
)))
223 (shiftf state saved-state
0)) ; pop the state
225 (when (state= to-state
&rest
) ; store a disambiguation bit
226 (setq rest-bits
(logior rest-bits
(if (eq arg
'&body
) 1 2))))
228 ;; Try to avoid using the imprecise "Misplaced" message if
229 ;; a better thing can be said, e.g. &WHOLE must go to the front.
230 (cond ((logbitp to-state seen
) ; Oops! Been here before.
232 (croak "~S and ~S are mutually exclusive: ~S"
234 (croak "repeated ~S in lambda list: ~S" arg list
)))
235 ((logbitp state from-states
) ; valid transition
237 seen
(logior seen
(ash 1 state
))
238 tail nil
)) ; Reset the accumulator.
239 ((logbitp state
(bits &whole
&rest
&more
&environment
))
240 (need-arg last-arg
)) ; Variable expected.
242 (croak (if (state= to-state
&whole
)
243 "~A must appear first in a lambda list: ~S"
244 "misplaced ~A in lambda list: ~S")
247 ;; Fell through, so warn if desired, and fall through some more.
248 (unless silent
(report-suspicious "variable" arg
)))
250 ;; Handle a lambda variable
251 (when (logbitp state
(bits &allow-other-keys
; Not a collecting state.
252 :post-env
:post-rest
:post-more
))
253 (croak "expected lambda list keyword at ~S in: ~S" arg list
))
254 (let ((item (list arg
)))
255 (setq tail
(if tail
(setf (cdr tail
) item
) (begin-list item
))))
256 (when (logbitp state
(bits &rest
&more
&whole
&environment
))
257 (let ((next (cond ((state= state
&rest
) (state :post-rest
))
258 ((state= state
&whole
) (state :required
))
259 ((state= state
&more
) ; Should consume 2 symbols
260 (if (cdr more
) (state :post-more
)))
261 ;; Current state must be &ENVIRONMENT
262 ((and (state= saved-state
:required
) (not required
))
263 (state :required
)) ; Back to start state
265 (state :post-env
))))) ; Need a lambda-list-keyword
266 (when next
; Advance to new state.
267 (setq state next tail nil
))))
270 #-sb-xc-host
;; Supress &OPTIONAL + &KEY syle-warning on xc host
271 (when (and (logtest (bits &key
) seen
) optional
(not silent
))
273 "&OPTIONAL and &KEY found in the same lambda list: ~S" list
))
275 ;; For CONTEXT other than :VALUES-TYPE/:FUNCTION-TYPE we reject
276 ;; illegal list elements. Type specifiers have arbitrary shapes,
277 ;; such as (VALUES (ARRAY (MUMBLE) (1 2)) &OPTIONAL (MEMBER X Y Z)).
278 ;; But why don't we reject constant symbols here?
279 (unless (member context
'(:values-type
:function-type
))
281 ;; Refer to the comment above the :destructuring-whole test
282 ;; in lambda-list.pure as to why &WHOLE has two personalities.
283 (funcall (if (logtest (bits &environment
) accept
)
284 #'need-symbol
#'need-bindable
)
285 (car whole
) "&WHOLE argument"))
286 (dolist (arg required
)
287 (if (eq context
'defmethod
)
288 (unless (or (and (symbolp arg
) (not (null arg
)))
289 (and (listp arg
) (singleton-p (cdr arg
))))
290 (croak "arg is not a non-NIL symbol or a list of two elements: ~A"
292 (need-bindable arg
"Required argument")))
293 ;; FIXME: why not check symbol-ness of supplied-p variables now?
294 (flet ((scan-opt/key
(list what-kind description
)
296 (when (defaultp arg what-kind
)
297 ;; FIXME: (DEFUN F (&OPTIONAL (A B C D)) 42) crashes the
298 ;; compiler, but not as consequence of the new parser.
299 ;; (This is not a regression)
300 (destructuring-bind (var &optional default sup-p
) arg
301 (if (and (consp var
) (eq what-kind
'&key
))
302 (destructuring-bind (keyword-name var
) var
303 (unless (symbolp keyword-name
)
304 (croak "keyword-name in ~S is not a symbol" arg
))
305 (need-bindable var description
))
306 (need-bindable var description
))
307 ;; Inform the user about a possibly malformed
308 ;; destructuring list (&OPTIONAL (A &OPTIONAL B)).
309 ;; It's technically legal but unlikely to be right,
310 ;; as A's default form is the symbol &OPTIONAL,
311 ;; which is an unlikely name for a local variable,
312 ;; and an illegal name for a DEFVAR or such,
313 ;; being in the CL package.
315 (check-suspicious "default" default
)
316 (check-suspicious "supplied-p variable" sup-p
)))))))
317 (scan-opt/key optional
'&optional
"&OPTIONAL parameter name")
319 (need-bindable (car rest
) "&REST argument"))
320 (scan-opt/key keys
'&key
"&KEY parameter name")
322 (when (defaultp arg
'&aux
)
323 ;; FIXME: also potentially compiler-crash-inducing
324 (destructuring-bind (var &optional init-form
) arg
325 (declare (ignore init-form
))
326 ;; &AUX is not destructured
327 (need-symbol var
"&AUX parameter name"))))))
330 (values (logior seen
(if (oddp rest-bits
) (bits &body
) 0))
331 required optional
(or rest more
) keys aux env whole
))))
333 ;;; Construct an abstract representation of a destructuring lambda list
334 ;;; from its source form, recursing as necessary.
335 ;;; Warn if it looks like a default expression will cause pattern mismatch.
336 ;;; There are other things we could issue style warnings about:
337 ;;; - a &REST arg that destructures preceded by any optional args.
338 ;;; It's suspicious because if &REST destructures, then in essence it
339 ;;; must not be NIL, which means the optionals aren't really optional.
340 (defun parse-ds-lambda-list (lambda-list
342 (condition-class 'simple-program-error
))
343 (multiple-value-bind (llks required optional rest keys aux env whole
)
344 (parse-lambda-list lambda-list
345 :accept
(lambda-list-keyword-mask 'destructuring-bind
)
346 :context
'destructuring-bind
347 :silent silent
:condition-class condition-class
)
348 (declare (ignore env
) (notinline mapcar
))
349 (labels ((parse (list)
350 (if (atom list
) list
(parse-ds-lambda-list list
:silent silent
)))
351 (parse* (list arg-specifier
)
352 (let ((parse (parse list
)))
353 (when (and (not silent
) (vectorp parse
)) ; is destructuring
354 (let ((default (and (cdr arg-specifier
) ; have an explicit default
355 (cadr arg-specifier
))))
356 (when (and (constantp default
)
357 (not (ds-lambda-list-match-p
358 (#+sb-xc constant-form-value
#-sb-xc eval
360 (meta-abstractify-ds-lambda-list parse
))))
362 "Default expression ~S does not match ~S in ~S"
363 default list lambda-list
))))
366 (mapcar #'parse whole
) ; a singleton or NIL
367 (mapcar #'parse required
)
369 (if (atom x
) x
(cons (parse* (car x
) x
) (cdr x
))))
371 (mapcar #'parse rest
) ; a singleton or NIL
373 (if (typep x
'(cons cons
))
374 (cons (list (caar x
) (parse* (cadar x
) x
)) (cdr x
))
379 ;; Bind the parts of the abstract representation of a destructuring
380 ;; lambda list, a (SIMPLE-VECTOR 7), to individual symbols.
381 (defmacro with-ds-lambda-list-parts
((&rest parts-names
) parts
&body body
)
382 (aver (<= 1 (length parts-names
) 7))
383 (once-only ((parts `(the (simple-vector 7) ,parts
)))
384 `(let ,(loop for i from
0 for sym in parts-names
385 when sym collect
`(,sym
(svref ,parts
,i
)))
388 ;;; Split an optional argument specifier into the bound variable
389 ;;; or destructuring pattern, the default, and supplied-p var.
390 ;;; If present the supplied-p var is in a singleton list.
391 ;;; DEFAULT should be specified as '* when parsing a DEFTYPE lambda-list.
392 (defun parse-optional-arg-spec (spec &optional default
)
394 (symbol (values spec default nil
))
395 (cons (values (car spec
)
396 (if (cdr spec
) (cadr spec
) default
)
399 ;;; Split a keyword argument specifier into the keyword, the bound variable
400 ;;; or destructuring pattern, the default, and supplied-p var.
401 ;;; If present the supplied-p var is in a singleton list.
402 ;;; DEFAULT should be specified as '* when parsing a DEFTYPE lambda-list.
403 (defun parse-key-arg-spec (spec &optional default
)
405 (symbol (values (keywordicate spec
) spec default nil
))
406 (cons (destructuring-bind (var &optional
(def default
) . sup-p-var
) spec
408 (values (keywordicate var
) var def sup-p-var
)
409 (values (car var
) (cadr var
) def sup-p-var
))))))
411 ;;; Return a "twice abstracted" representation of DS-LAMBDA-LIST that removes
412 ;;; all variable names, &AUX parameters, supplied-p variables, and defaults.
413 ;;; The result is a list with trailing suffixes of NIL dropped, and which can
414 ;;; be given to an AST matcher yielding a boolean answer as to whether some
415 ;;; input matches, with one caveat: Destructured &OPTIONAL or &KEY default
416 ;;; forms may cause failure of a destructuring-bind due to inner expressions
417 ;;; causing mismatch. In most cases this can not be anticipated.
418 (defun meta-abstractify-ds-lambda-list (parsed-ds-lambda-list)
419 (labels ((process-opt/key
(x) (recurse (if (listp x
) (car x
) x
)))
421 (when (symbolp thing
)
422 (return-from recurse t
))
423 (with-ds-lambda-list-parts (llks whole req opt rest keys
) thing
425 (when (ll-kwds-keyp llks
)
426 (cons (ll-kwds-allowp llks
)
428 (cons (parse-key-arg-spec x
)
429 (if (typep x
'(cons cons
))
431 (process-opt/key x
))))
433 ;; Compute reversed representation of req, opt, rest.
434 (repr (list (when rest
(recurse (car rest
)))
435 (mapcar #'process-opt
/key opt
)
436 (mapcar #'recurse req
))))
437 ;; If &KEYS are present, then req, opt, rest must be too.
438 ;; But if not, then pop leading NILs (which become trailing
439 ;; NILs). Missing parts aren't stored.
440 ;; A degenerate ds-lambda-list accepting 0 args is just ().
442 (loop (if (or (null repr
) (car repr
)) (return) (pop repr
))))
443 (let ((result (nreconc repr keys
))
445 (if (vectorp whole
) ; Destructuring. Ugh.
446 ;; The input must match two things - a tree implied by
447 ;; the nested &WHOLE, and a tree that contains it.
448 `(:both
,(recurse whole
) ,@result
)
450 (recurse parsed-ds-lambda-list
)))
452 ;; Construct a lambda list from sublists.
453 ;; If &WHOLE and REST are present, they must be singleton lists.
454 ;; Any sublists that were obtained by parsing a destructuring
455 ;; lambda list must be supplied in their unparsed form.
456 (defun make-lambda-list (llks whole required
&optional optional rest keys aux
)
457 (append (when whole
(cons '&whole whole
))
459 (when (logtest (lambda-list-keyword-mask '&optional
) llks
)
460 (cons '&optional optional
))
461 (let ((restp (ll-kwds-restp llks
)))
462 (if (and rest
(not restp
)) ; lambda list was "dotted"
465 (when rest
(cons restp rest
))
466 (if (ll-kwds-keyp llks
) (cons '&key keys
)) ; KEYS can be nil
467 (if (ll-kwds-allowp llks
) '(&allow-other-keys
))
468 ;; Should &AUX be inserted even if empty? Probably not.
469 (if aux
(cons '&aux aux
)))))))
471 ;;; Produce a destructuring lambda list from its internalized representation,
472 ;;; excluding any parts that don't constrain the shape of the expected input.
473 ;;; &AUX, supplied-p vars, and defaults do not impose shape constraints.
475 ;;; However as a special case, some constant defaults are retained mainly for
476 ;;; backward-compatibility.
477 ;;; The reason for it is that a test in SB-INTROSPECT checks the lambda list
478 ;;; of type ARRAY, which has explicit '* defaults. They're explicit
479 ;;; because of a bug or deficiency in !DEF-TYPE-TRANSLATOR which does not
480 ;;; adhere to the convention that DEFTYPE-like lambda lists use '* as implicit
481 ;;; defaults for everything unless stated otherwise.
482 ;;; So really the '* should have been superfluous in the lambda list,
483 ;;; but I'm also not convinced that changing the test case is the right thing.
485 (defun unparse-ds-lambda-list (parsed-lambda-list &optional cache
)
486 (cond ((symbolp parsed-lambda-list
) parsed-lambda-list
)
487 ((cdr (assq parsed-lambda-list
(cdr cache
))))
489 (with-ds-lambda-list-parts (llks whole req optional rest keys
)
491 (labels ((process-opt (spec)
494 (cons (recurse (car spec
)) (maybe-default spec
))))
495 (maybe-default (spec)
496 (let ((def (cdr spec
)))
497 (when (and def
(typep (car def
)
498 '(or (cons (eql quote
))
501 (list (car def
))))) ; Remove any supplied-p var.
502 (recurse (x) (unparse-ds-lambda-list x cache
))
503 (memoize (input output
)
504 (when cache
(push (cons input output
) (cdr cache
)))
510 ;; &WHOLE is omitted unless it destructures something.
511 (when (vectorp (car whole
)) (list (recurse (car whole
))))
512 (mapcar #'recurse req
)
513 (mapcar #'process-opt optional
)
514 (when rest
(list (recurse (car rest
))))
516 (if (typep x
'(cons cons
))
517 (cons (list (caar x
) (recurse (cadar x
)))
522 ;;; Return the list of variables bound by a destructuring lambda list.
523 ;;; One purpose for this is to help expand destructuring-bind using
524 ;;; a strategy that delivers values to an MV-BIND.
525 ;;; It would otherwise be difficult to wrap a condition handler
526 ;;; around only the binding creation forms and not the body
527 ;;; of the destructuring-bind. Consider e.g.
529 (DESTRUCTURING-BIND (A &OPTIONAL
(B 0) (C 'DEF
)) L
(DOER))
530 -
> (multiple-value-bind (a b c
)
531 (handler-bind ((error (lambda (c) (return-from somewhere
))))
532 (values (pop (the cons L
))
534 (cond ((endp L
) 'def
)
535 ((endp (cdr L
)) (car L
))
536 (t (error "Excess args")))))
539 (defun ds-lambda-list-variables (parsed-lambda-list &optional
(include-aux t
))
541 (labels ((recurse (x) (if (vectorp x
) (scan x
) (output x
)))
542 (copy (x) (dolist (elt x
) (recurse elt
)))
543 (suppliedp-var (spec) (if (cddr spec
) (output (third spec
))))
545 (with-ds-lambda-list-parts (nil whole req opt rest key aux
) parts
549 (cond ((symbolp x
) (output x
))
554 (cond ((symbolp x
) (output x
))
555 (t (let ((k (car x
)))
556 (if (symbolp k
) (output k
) (recurse (cadr k
)))
557 (suppliedp-var x
)))))
560 (output (if (symbolp x
) x
(car x
))))))))
561 (recurse parsed-lambda-list
)
564 ;;; Return T if OBJECT matches TEMPLATE, where TEMPLATE is a meta-abstractified
565 ;;; destructuring lambda list. Mnemonic: the arguments are like TYPEP.
566 ;;; [Indeed the AST could be a monstrous type specifier involving {CONS,AND,OR}
567 ;;; except for lambda lists that involve keywords.]
569 (defun ds-lambda-list-match-p (object template
)
570 (macrolet ((pop-template () '(pop (truly-the list template
)))
572 '(unless template
(return-from recurse
(null args
))))
574 '(return-from recurse nil
)))
575 ;; When a failure occurs, we could return all the way out, but that would
576 ;; mean establishing a dynamic exit. Instead let failure bubble up.
577 (labels ((recurse (template args
)
578 (accept) ; Exit if no required, optional, rest, key args.
579 (when (eq (car (truly-the list template
)) :both
)
581 (and (recurse (cadr template
) args
)
582 (recurse (cddr template
) args
))))
584 (dolist (subpat (pop-template)) ; For each required argument
585 (let ((arg (if (atom args
) (fail) (pop args
))))
586 (when (and (listp subpat
) (not (recurse subpat arg
)))
588 (accept) ; Exit if no optional, rest, key args.
590 (dolist (subpat (pop-template))
591 (let ((arg (cond ((not (listp args
)) (fail))
593 ;; Why not just return T now?
594 ;; Because destructured &REST maybe.
597 (return-from recurse t
)))
599 (when (and (listp subpat
) (not (recurse subpat arg
)))
601 (accept) ; Exit if no rest, key args.
602 ;; If REST is not a cons, that's fine - it's either T, meaning
603 ;; that it was present but not a pattern, or NIL, meaning
604 ;; absent, in which case &KEY must have been present,
605 ;; otherwise the preceding (ACCEPT) would have returned.
606 (let ((rest (pop-template)))
607 (when (and (consp rest
) (not (recurse rest args
)))
609 (when (null template
) ; No keys.
610 (return-from recurse t
))
611 ;; Now test all keywords against the allowed ones, even if
612 ;; &ALLOW-OTHER-KEYS was present. Any key's value might bind
613 ;; to a subpattern, and the lambda list could be insane as well:
614 ;; (&KEY ((:allow-other-keys (x)) '(foo)))
615 ;; where the value of :ALLOW-OTHER-KEYS must apparently
617 (prog ((allowp (if (pop template
) t
0)) seen-other
)
620 (return (or (not seen-other
) (eq allowp t
))))
621 (unless (listp args
) (return nil
))
622 (let* ((next (cdr args
))
624 (cell (assq key template
)))
625 (unless (consp next
) (return nil
))
628 (let ((pattern (cdr cell
)))
629 (when (and (listp pattern
)
630 (not (recurse pattern
(car next
))))
632 (when (and (eq key
:allow-other-keys
) (eql allowp
0))
633 (setq allowp
(if (car next
) t nil
)))
634 (setq args
(cdr next
)))
636 (recurse template object
))))
638 ;;; Return the AST that recognizes inputs matching DS-LAMBDA-LIST.
639 (defun ds-lambda-list-matcher (ds-lambda-list)
640 (meta-abstractify-ds-lambda-list (parse-ds-lambda-list ds-lambda-list
)))
642 ;;; Emit a form to test whether INPUT matches DS-LAMBDA-LIST.
643 ;;; It's up to this function to decide (perhaps based on policy)
644 ;;; how to generate the code. There are a few simple cases that avoid
645 ;;; function calls. Others could easily be added. e.g. a 2-list could be:
646 ;;; (TYPEP INPUT '(CONS T (CONS T NULL)))
647 (defun emit-ds-lambda-list-match (input ds-lambda-list
)
648 (let ((matcher (ds-lambda-list-matcher ds-lambda-list
)))
649 ;; To match exactly 1 required arg, use SINGLETON-P.
650 (cond ((equal matcher
'((t))) `(singleton-p ,input
))
651 ;; Matching 0 required, 0 optional, and rest is trivially T.
652 ((equal matcher
'(() () t
)) t
)
653 (t `(ds-lambda-list-match-p ,input
',matcher
)))))
655 ;;; Emit a correctness check for one level of structure in PARSED-LAMBDA-LIST
656 ;;; which receives values from INPUT.
657 ;;; MACRO-CONTEXT provides context for the diagnostic message.
658 ;;; MEMO-TABLE is an alist of previously-unparsed parsed-lambda-lists.
659 ;;; The checker returns INPUT if it was well-formed, or signals an error.
661 ;;; There is a better way (not implemented) to check &KEY arguments: assume
662 ;;; optimistically that unknown/duplicate keywords aren't frequent, and perform
663 ;;; all GETF operations for known keywords into temp vars; count the ones that
664 ;;; found something, and compare to the plist length/2. If not equal, then do
665 ;;; a further check. Otherwise we've done most of the work of parsing;
666 ;;; just move the temps into their final places in turn.
668 (defun emit-ds-bind-check (parsed-lambda-list input macro-context memo-table
)
669 (with-ds-lambda-list-parts (llks nil req opt rest keys
) parsed-lambda-list
670 (let* ((display (unparse-ds-lambda-list parsed-lambda-list memo-table
))
671 (pattern `',(if macro-context
(cons macro-context display
) display
))
673 (max (+ min
(length opt
)))
674 (bounds (list min max
)))
675 (cond ((ll-kwds-keyp llks
)
676 `(,(if (eq (cddr macro-context
) 'define-compiler-macro
)
677 'cmacro-check-ds-list
/&key
679 ,input
,@bounds
,pattern
680 ,(unless (ll-kwds-allowp llks
)
681 (map 'vector
#'parse-key-arg-spec keys
))))
682 ;; The case that need not check anything at all:
683 ;; no keys, no required, no optional, and a &rest arg.
684 ((and rest
(eql max
0)) input
) ; nothing to check
685 (rest `(check-ds-list/&rest
,input
,@bounds
,pattern
))
686 (t `(check-ds-list ,input
,@bounds
,pattern
))))))
688 ;;; Produce the binding clauses for a BINDING* form that destructures
689 ;;; LAMBDA-LIST from input in DATA.
690 ;;; EMIT-PRE-TEST, if true, will diagnose most (but not all) structural
691 ;;; errors [*] before executing user-supplied code in defaulting forms.
692 ;;; EXPLICIT-CAST is one of {THE, TRULY-THE, NIL} to insert casts or not.
693 ;;; Optional MACRO-CONTEXT provides context for the error strings.
694 ;;; DEFAULT-DEFAULT, which defaults to NIL, supplies the value for optional
695 ;;; and key arguments which were absent and had no explicit defaulting form.
697 ;;; Without explicit casts, the input must satisfy LISTP at each CAR/CDR step.
698 ;;; If pre-tests were done and user code did not smash the input, then it
699 ;;; will satisfy LISTP, and EXPLICIT-CAST may be specified as 'TRULY-THE
700 ;;; to omit compiler-generated ("checkgen") tests. If pre-tests were not done,
701 ;;; then EXPLICIT-CAST should be specified as 'THE to strengthen type tests
702 ;;; into (THE CONS x) at mandatory arguments.
704 ;;; [*] "Structural errors" are those due to mismatch of the input against
705 ;;; the template; in the case of one list level, an error can be signaled
706 ;;; before defaults are evaluated, but with nested destructuring, this is not
707 ;;; always possible. Previously there was an attempt to check outer lists
708 ;;; before proceeding to inner lists, but this required departure from
709 ;;; customary left-to-right evaluation order of source forms as written.
710 ;;; The new scheme seems more in accordance with other Lisp implementations.
711 ;;; Portable code should probably not rely on the order in which structural
712 ;;; errors are tested for. If input is well-formed - it matches the template -
713 ;;; then there is no possibility of user code sensing the order in which
714 ;;; well-formedness tests ran.
716 (defun expand-ds-bind (lambda-list data emit-pre-test explicit-cast
717 &optional macro-context default-default
)
718 (collect ((cache (list nil
)) ; This is a "scratchpad" for the unparser.
721 (;; Bind VAR from VAL-FORM. VAR can be a symbol or ds-lambda-list.
722 (bind-pat (var val-form
)
723 (if (symbolp var
) (bind `(,var
,val-form
)) (descend var val-form
)))
724 ;; Conditionally bind VAR from VAL-FORM based on SUP-P-FORM.
725 (bind-if (sense sup-p-form val-form var sup-p-var def
)
726 (let* ((suppliedp (car sup-p-var
)) ; could be nil
727 (vals (gen-test sense sup-p-form
728 (if sup-p-var
`(values ,val-form t
) val-form
)
730 (cond ((not sup-p-var
) (bind-pat var vals
))
731 ((symbolp var
) (bind `((,var
,suppliedp
) ,vals
)))
733 (let ((var-temp (sb!xc
:gensym
))
734 (sup-p-temp (copy-symbol suppliedp
)))
735 (bind `((,var-temp
,sup-p-temp
) ,vals
))
736 (descend var var-temp
)
737 (bind `(,suppliedp
,sup-p-temp
)))))))
738 (gen-test (sense test then else
)
739 (cond ((eq sense t
) `(if ,test
,then
,@(if else
(list else
))))
740 (else `(if ,test
,else
,then
)) ; flip the branches
741 (t `(if (not ,test
) ,then
)))) ; invert the test
742 (descend (parsed-lambda-list input
)
743 (with-ds-lambda-list-parts (llks whole required opt rest keys aux
)
745 ;; There could be nothing but &AUX vars in the lambda list.
746 ;; If nothing to bind from INPUT, then ignore "ds-check" result.
747 ;; But if keywords are accepted, always call the checker.
748 ;; A feature of BINDING* is that binding something to () means,
749 ;; in theory, (MULTIPLE-VALUE-BIND () (EXPR) ...)
750 ;; but in practice it becomes a binding of an ignored gensym.
751 (let* ((bindings-p (or whole required opt rest keys
))
752 (temp (and bindings-p
(sb!xc
:gensym
))))
754 ,(cond ((or emit-pre-test
(ll-kwds-keyp llks
))
755 (emit-ds-bind-check parsed-lambda-list input
756 macro-context
(cache)))
757 ((or bindings-p
(not explicit-cast
)) input
)
758 ;; If nothing gets bound, then input must be NIL,
759 ;; unless &KEY is accepted, which was done above.
760 (t `(,explicit-cast null
,input
)))))
762 ;; I would think it totally absurd to use something
763 ;; other than a symbol for &WHOLE, but the spec allows it.
764 (when whole
(bind-pat (car whole
) input
))
766 (flet ((cast/pop
(typed-list-expr more-to-go
)
767 `(prog1 (car ,typed-list-expr
)
768 ,(if (or more-to-go rest
(ll-kwds-keyp llks
))
769 `(setq ,input
(cdr ,input
))
770 `(,explicit-cast null
(cdr ,input
))))))
771 ;; Mandatory args. Only the rightmost need check that it sees
772 ;; a CONS. The predecessors will naturally assert that the
773 ;; input so far was of type LIST, which is enough.
774 (do ((elts required
(cdr elts
)))
778 (cast/pop
`(,explicit-cast
779 ,(if (cdr elts
) 'list
'cons
) ,input
)
783 (do ((elts opt
(cdr elts
)))
785 (multiple-value-bind (var def sup-p-var
)
786 (parse-optional-arg-spec (car elts
) default-default
)
789 (cast/pop
`(,explicit-cast list
,input
)
792 var sup-p-var def
))))
794 ;; The spec allows the inane use of (A B &REST (C D)) = (A B C D).
795 ;; The former is less efficient, since it is "nested", only not.
796 (when rest
(bind-pat (car rest
) input
))
800 (multiple-value-bind (keyword var def sup-p-var
)
801 (parse-key-arg-spec elt default-default
)
802 (let ((temp (sb!xc
:gensym
)))
803 (bind `(,temp
(ds-getf ,input
',keyword
)))
804 (bind-if :not
`(eql ,temp
0) `(car (truly-the cons
,temp
))
805 var sup-p-var def
))))
807 ;; &AUX bindings aren't destructured. Finally something easy.
809 (multiple-value-bind (var val
)
810 (if (listp elt
) (values (car elt
) (cadr elt
)) elt
)
811 (bind `(,var
,val
)))))))
813 (descend (parse-ds-lambda-list lambda-list
) data
)
818 ;; Given FORM as the input to a compiler-macro, return the argument forms
819 ;; that the called function would receive, skipping over FUNCALL.
820 (defun compiler-macro-args (form)
821 (cdr (if (eql (car form
) 'funcall
) (cdr form
) form
)))
823 ;; Extract the context from a destructuring-bind pattern as represented in
824 ;; a call to a checking function. A "context" is a non-bindable subpattern
825 ;; headed by :MACRO (if it came from any macro-like thing, e.g. DEFTYPE),
827 ;; Return three values: CONTEXT-NAME, CONTEXT-KIND, and the real pattern.
828 (defun get-ds-bind-context (pattern)
829 (let ((marker (car pattern
)))
830 (case (and (listp marker
) (car marker
))
832 (let ((context (cdr marker
)))
833 (values (car context
) (cdr context
) (cdr pattern
))))
835 (values (cdr marker
) :special-form
(cdr pattern
)))
837 (values nil
:eval
(cdr pattern
)))
839 (values nil
'destructuring-bind pattern
)))))
841 ;;; Helpers for the variations on CHECK-DS-mumble.
842 (defun ds-bind-error (input min max pattern
)
843 (multiple-value-bind (name kind lambda-list
) (get-ds-bind-context pattern
)
845 (declare (optimize sb
!c
::allow-non-returning-tail-call
))
848 ;; IR1 translators should call COMPILER-ERROR instead of
849 ;; ERROR. To ingrain that knowledge into the CHECK-DS-foo
850 ;; functions is a bit of a hack, but to do otherwise
851 ;; changes how DS-BIND has to expand.
852 (compiler-error 'sb
!kernel
::arg-count-error
853 :kind
"special operator" :name name
854 :args input
:lambda-list lambda-list
855 :minimum min
:maximum max
))
858 (error 'sb
!eval
::arg-count-program-error
859 ;; This is stupid. Maybe we should just say
860 ;; "error parsing special form"?
861 ;; It would be more sensible than mentioning
862 ;; a random nonstandard macro.
863 :kind
'sb
!eval
::program-destructuring-bind
864 :args input
:lambda-list lambda-list
865 :minimum min
:maximum max
))
867 (error 'sb
!kernel
::arg-count-error
868 :kind kind
:name name
869 :args input
:lambda-list lambda-list
870 :minimum min
:maximum max
)))))
872 (defun check-ds-bind-keys (input plist valid-keys pattern
)
873 ;; Check just the keyword portion of the input in PLIST
874 ;; against VALID-KEYS. If VALID-KEYS = NIL then we don't care what
875 ;; the keys are - &ALLOW-OTHER-KEYS was present in the lambda-list,
876 ;; and we don't care if non-symbols are found in keyword position.
877 ;; Always enforce that the list has even length though.
878 (let* (seen-allowp seen-other bad-key
884 (return :unknown-keyword
)
885 (return-from check-ds-bind-keys input
)))
886 (unless (listp tail
) (return :dotted-list
))
887 (let ((next (cdr tail
)))
888 (when (null next
) (return :odd-length
))
889 (unless (listp next
) (return :dotted-list
))
890 (let ((key (car tail
)))
892 (if (eq key
:allow-other-keys
) ; always itself allowed
895 (when (car next
) ; :allow-other-keys <non-nil>
896 (setf seen-other nil valid-keys nil
)))
897 (unless (or seen-other
898 (find key
(truly-the simple-vector valid-keys
)
900 (setq seen-other t bad-key key
)))))
901 (setq tail
(cdr next
))))))
902 (multiple-value-bind (kind name
) (get-ds-bind-context pattern
)
904 (declare (optimize sb
!c
::allow-non-returning-tail-call
))
905 (error 'sb
!kernel
::defmacro-lambda-list-broken-key-list-error
906 :kind kind
:name name
908 :info
(if (eq problem
:unknown-keyword
)
909 ;; show any one unaccepted keyword
910 (list bad-key
(coerce valid-keys
'list
))
913 (macrolet ((scan-req-opt ((input min max pattern list-name actual-max
)
914 &key if-list-exhausted if-max-reached
)
915 ;; Decide whether the input matches up to the end of
916 ;; the required and/or optional arguments.
917 ;; MAX is the limit on number of CDR operations performed
918 ;; in the loop. ACTUAL-MAX describes the upper bound
919 ;; in a condition reporting function.
920 ;; e.g. (A &OPTIONAL B &REST C) has MAX = 2, ACTUAL-MAX = NIL.
921 ;; The input must be a proper list up to 2 arguments,
922 ;; but beyond that may be dotted.
923 `(let ((,list-name
,input
) (count ,max
))
924 (declare (type index count
))
925 (loop (when (zerop count
) (return ,if-max-reached
))
926 (when (null ,list-name
)
928 (if (< (- max count
) ,min
)
929 (ds-bind-error ,input
,min
,actual-max
,pattern
)
930 ,if-list-exhausted
)))
931 (unless (listp ,list-name
) ; dotted list error
933 (ds-bind-error ,input
,min
,actual-max
,pattern
)))
935 (setq ,list-name
(cdr ,list-name
))))))
937 ;; Assert that INPUT has the requisite number of elements as
938 ;; specified by MIN/MAX. PATTERN does not contain &REST or &KEY.
939 (defun check-ds-list (input min max pattern
)
940 (declare (type index min max
) (optimize speed
))
941 (scan-req-opt (input min max pattern list max
)
942 ;; If 'count' became zero, then since there was
943 ;; no &REST, the LIST had better be NIL.
945 (if list
(ds-bind-error input min max pattern
) input
)
946 ;; The loop checks for dotted tail and >= MIN elements,
947 ;; so end of list means a valid match to the pattern.
948 :if-list-exhausted input
))
950 ;; As above, but the pattern contains &REST.
951 ;; Elements beyond the final optional arg can form a dotted list.
952 (defun check-ds-list/&rest
(input min max pattern
)
953 (declare (type index min max
) (optimize speed
))
954 (scan-req-opt (input min max pattern list nil
)
955 :if-list-exhausted input
:if-max-reached input
))
957 ;; The pattern contains &KEY. Anything beyond the final optional arg
958 ;; must be a well-formed property list regardless of existence of &REST.
959 (defun check-ds-list/&key
(input min max pattern valid-keys
)
960 (declare (type index min max
) (optimize speed
))
961 (scan-req-opt (input min max pattern list nil
)
962 :if-list-exhausted input
963 :if-max-reached
(check-ds-bind-keys
964 input list valid-keys pattern
)))
966 ;; Compiler-macro lambda lists are macro lambda lists -- meaning that
967 ;; &key ((a a) t) should match a literal A, not a form evaluating to A
968 ;; as in an ordinary lambda list.
970 ;; That, however, breaks the evaluation model unless A is also a
971 ;; constant evaluating to itself. So, signal a condition telling the
972 ;; compiler to punt on the expansion.
973 ;; Moreover it has to be assumed that any non-constant might
974 ;; evaluate to :ALLOW-OTHER-KEYS.
976 ;; The reason this is its own function is for separation of concerns.
977 ;; Suppose that CHECK-DS-LIST/&KEY had a short-circuit exit wherein
978 ;; seeing ":ALLOW-OTHER-KEYS <non-nil>" stopped testing for keywords in
979 ;; the accepted list, but instead quickly scanned for a proper tail.
980 ;; (It doesn't, but suppose it did). A compiler-macro must nonetheless
981 ;; finish looking for all non-constant symbols in keyword positions.
982 ;; More realistically, if the optimization for &KEY mentioned above
983 ;; EMIT-DS-BIND-CHECK were implemented, where perhaps we elide a call
984 ;; to validate keywords, a compiler-macro is probably always best
985 ;; handled by a out-of-line call on account of the extra hair.
987 (defun cmacro-check-ds-list/&key
(input min max pattern valid-keys
)
988 (declare (type index min max
) (optimize speed
))
989 (scan-req-opt (input min max pattern list nil
)
990 :if-list-exhausted input
992 ;; Signal a condition if the compiler should give up
993 ;; on expanding. Well-formedness of the plist
994 ;; makes no difference, since CHECK-DS-BIND-KEYS is stricter.
995 ;; If the condition isn't handled, we just press onward.
997 (loop (when (atom plist
) (return))
998 (let ((key (pop plist
)))
999 (when (atom plist
) (return))
1001 (unless (or (keywordp key
)
1004 (eq key
(symbol-value key
))))
1005 (signal 'compiler-macro-keyword-problem
1007 (check-ds-bind-keys input list valid-keys pattern
)))))
1009 ;; Like GETF but return CDR of the cell whose CAR contained the found key,
1010 ;; instead of CADR; and return 0 for not found.
1011 ;; This helps destructuring-bind slightly by avoiding a secondary value as a
1012 ;; found/not-found indicator, and using 0 is better for backends which don't
1013 ;; wire a register to NIL. Also, NIL would accidentally allow taking its CAR
1014 ;; if the caller were to try, whereas we'd want to see a explicit error.
1015 (defun ds-getf (place indicator
)
1016 (do ((plist place
(cddr plist
)))
1018 (cond ((atom (cdr plist
))
1019 (error 'simple-type-error
1020 :format-control
"malformed property list: ~S."
1021 :format-arguments
(list place
)
1023 :expected-type
'cons
))
1024 ((eq (car plist
) indicator
)
1025 ;; Typecheck the next cell so that calling code doesn't get an atom.
1026 (return (the cons
(cdr plist
)))))))
1028 ;;; This is a variant of destructuring-bind that provides the name
1029 ;;; of the containing construct in generated error messages.
1030 (def!macro named-ds-bind
(context lambda-list data
&body body
&environment env
)
1031 (declare (ignorable env
))
1032 `(binding* ,(expand-ds-bind lambda-list data t nil context
1033 (and (eq (car context
) :macro
)
1034 (eq (cddr context
) 'deftype
)
1038 ;;; Make a lambda expression that receives an s-expression, destructures it
1039 ;;; according to LAMBDA-LIST, and executes BODY.
1040 ;;; NAME and KIND provide error-reporting context.
1041 ;;; DOC-STRING-ALLOWED can be :INTERNAL to allow a docstring which is kept
1042 ;;; inside the lambda, or :EXTERNAL to pull it out and return it, or NIL.
1043 ;;; ENVIRONMENT can be NIL to disallow an &ENVIRONMENT variable,
1044 ;;; or :IGNORE to allow it, but bind the corresponding symbol to NIL.
1045 ;;; WRAP-BLOCK, if true, will place a block named NAME around body.
1047 ;;; The secondary value is a docstring, if requested as :EXTERNAL.
1049 ;;; The lambda contains an internal declaration of its argument list
1050 ;;; that discards &ENVIRONMENT, &WHOLE, and/or anything else that does
1051 ;;; not document the expected list shape.
1053 ;;; The CLtl2 name for this operation is PARSE-MACRO.
1054 (defun make-macro-lambda
1055 (lambda-name lambda-list body kind name
1056 &key
((:environment envp
) t
) (doc-string-allowed :internal
)
1058 (declare (type (member t nil
:ignore
) envp
))
1059 (declare (type (member nil
:external
:internal
) doc-string-allowed
))
1060 (binding* (((forms decls docstring
)
1061 (parse-body body
:doc-string-allowed 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
))
1089 (if (eq kind
'define-compiler-macro
) 'compiler-macro-args
'cdr
)))
1090 ;; Signal a style warning for duplicate names, but disregard &AUX variables
1091 ;; because most folks agree that (LET* ((X (F)) (X (G X))) ..) makes sense
1092 ;; - some would even say that it is idiomatic - and &AUX bindings are just
1094 ;; The obsolete PARSE-DEFMACRO signaled an error, but that seems harsh.
1095 ;; Other implementations permit (X &OPTIONAL X), and the fact that
1096 ;; nesting is allowed makes this issue even less clear.
1097 (mapl (lambda (tail)
1098 (when (memq (car tail
) (cdr tail
))
1099 (style-warn "variable ~S occurs more than once" (car tail
))))
1100 (append whole env
(ds-lambda-list-variables parse nil
)))
1101 (values `(,@(if lambda-name
`(named-lambda ,lambda-name
) '(lambda))
1102 (,ll-whole
,@ll-env
,@(and ll-aux
(cons '&aux ll-aux
)))
1103 ,@(when (and docstring
(eq doc-string-allowed
:internal
))
1104 (prog1 (list docstring
) (setq docstring nil
)))
1105 ;; Normalize the lambda list by unparsing.
1106 (declare (lambda-list ,(unparse-ds-lambda-list parse
)))
1107 ,@(if outer-decls
(list outer-decls
))
1108 ,@(and (not env
) (eq envp t
) `((declare (ignore ,@ll-env
))))
1109 ,@(sb!c
:macro-policy-decls
)
1111 `(named-ds-bind ,(if (eq kind
:special-form
)
1112 `(:special-form .
,name
)
1113 `(:macro
,name .
,kind
)))
1114 '(destructuring-bind))
1115 ,new-ll
(,arg-accessor
,ll-whole
)
1118 `((block ,(fun-name-block-name name
) ,@forms
))
1122 ;;; Functions should probably not retain &AUX variables as part
1123 ;;; of their reflected lambda list, but this is selectable
1124 ;;; because some users might claim that dropping &AUX is wrong.
1125 ;;; For system code, it's a measurably large waste of space,
1126 ;;; given how DEFTRANSFORM and a few other macros expand such
1127 ;;; that argument parsing is performed in &AUX var initforms.
1128 (defvar *strip-lamba-list-retain-aux
* #+sb-xc t
#-sb-xc nil
)
1130 ;;; Return LAMBDA-LIST with some pieces removed.
1131 (defun strip-lambda-list (lambda-list how
)
1132 (handler-case (parse-lambda-list lambda-list
:silent t
)
1133 (error () lambda-list
)
1134 (:no-error
(llks req opt rest keys aux
&rest ignore
)
1135 (declare (ignore ignore
))
1136 (multiple-value-bind (opt keys aux
)
1139 (values opt keys
(if *strip-lamba-list-retain-aux
* aux nil
)))
1140 ;; The name of an anonymous lambda is an arbitrary list,
1141 ;; not necessarily the original list.
1142 (:name
(values (mapcar #'parse-optional-arg-spec opt
); Keep name.
1143 (mapcar #'parse-key-arg-spec keys
) ; Keep keyword.
1144 nil
))) ; Discard &AUX vars
1145 (let ((new (make-lambda-list llks nil req opt rest keys aux
)))
1146 ;; It is harmful to the space-saving effect of this function
1147 ;; if reconstituting the list results in an unnecessary copy.
1148 (if (equal new lambda-list
) lambda-list new
))))))
1150 (/show0
"parse-lambda-list.lisp end of file")