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