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 ;;; Check the variable names and keywords in the sections of the
343 ;;; lambda list for illegal and repeated ones.
345 ;;; Can be wrapped around PARSE-LAMBDA-LIST like this:
347 ;;; (multiple-value-call #'check-lambda-list-names
348 ;;; (parse-lambda-list ...)
350 (defun check-lambda-list-names (llks required optional rest keys aux env whole
352 (context "an ordinary lambda list")
353 (signal-via #'compiler-error
)
354 (allow-symbol-macro t
))
355 (let ((names (make-repeated-name-check :signal-via signal-via
))
356 (keywords (make-repeated-name-check
357 :kind
"keyword" :signal-via signal-via
)))
358 (flet ((check-name (name)
359 (check-variable-name-for-binding
360 name
:context context
:signal-via signal-via
361 :allow-symbol-macro allow-symbol-macro
)
362 (funcall names name
)))
363 (mapc #'check-name required
)
365 (multiple-value-bind (name default suppliedp-var
)
366 (parse-optional-arg-spec spec
)
367 (declare (ignore default
))
370 (check-name (first suppliedp-var
)))))
372 (mapc #'check-name rest
)
374 (multiple-value-bind (keyword name default suppliedp-var
)
375 (parse-key-arg-spec spec
)
376 (declare (ignore default
))
379 (check-name (first suppliedp-var
)))
380 (funcall keywords keyword
)))
382 (values llks required optional rest keys aux env whole
))
384 ;;; Construct an abstract representation of a destructuring lambda list
385 ;;; from its source form, recursing as necessary.
386 ;;; Warn if it looks like a default expression will cause pattern mismatch.
387 ;;; There are other things we could issue style warnings about:
388 ;;; - a &REST arg that destructures preceded by any optional args.
389 ;;; It's suspicious because if &REST destructures, then in essence it
390 ;;; must not be NIL, which means the optionals aren't really optional.
391 (defun parse-ds-lambda-list (lambda-list
393 (condition-class 'simple-program-error
))
394 (multiple-value-bind (llks required optional rest keys aux env whole
)
395 (parse-lambda-list lambda-list
396 :accept
(lambda-list-keyword-mask 'destructuring-bind
)
397 :context
'destructuring-bind
398 :silent silent
:condition-class condition-class
)
399 (declare (ignore env
) (notinline mapcar
))
400 (labels ((parse (list)
402 (parse-ds-lambda-list list
:silent silent
)
404 (parse* (list arg-specifier
)
405 (let ((parse (parse list
)))
406 (when (and (not silent
) (vectorp parse
)) ; is destructuring
407 (let ((default (and (cdr arg-specifier
) ; have an explicit default
408 (cadr arg-specifier
))))
409 (when (and (constantp default
)
410 (not (ds-lambda-list-match-p
411 (#+sb-xc constant-form-value
#-sb-xc eval
413 (meta-abstractify-ds-lambda-list parse
))))
415 "Default expression ~S does not match ~S in ~S"
416 default list lambda-list
))))
419 (mapcar #'parse whole
) ; a singleton or NIL
420 (mapcar #'parse required
)
422 (if (atom x
) x
(cons (parse* (car x
) x
) (cdr x
))))
424 (mapcar #'parse rest
) ; a singleton or NIL
426 (if (typep x
'(cons cons
))
427 (cons (list (caar x
) (parse* (cadar x
) x
)) (cdr x
))
432 ;; Bind the parts of the abstract representation of a destructuring
433 ;; lambda list, a (SIMPLE-VECTOR 7), to individual symbols.
434 (defmacro with-ds-lambda-list-parts
((&rest parts-names
) parts
&body body
)
435 (aver (<= 1 (length parts-names
) 7))
436 (once-only ((parts `(the (simple-vector 7) ,parts
)))
437 `(let ,(loop for i from
0 for sym in parts-names
438 when sym collect
`(,sym
(svref ,parts
,i
)))
441 ;;; Split an optional argument specifier into the bound variable
442 ;;; or destructuring pattern, the default, and supplied-p var.
443 ;;; If present the supplied-p var is in a singleton list.
444 ;;; DEFAULT should be specified as '* when parsing a DEFTYPE lambda-list.
445 (defun parse-optional-arg-spec (spec &optional default
)
447 (symbol (values spec default nil nil
))
448 (cons (values (car spec
)
449 (if (cdr spec
) (cadr spec
) default
)
451 (when (cdr spec
) t
)))))
453 ;;; Split a keyword argument specifier into the keyword, the bound variable
454 ;;; or destructuring pattern, the default, and supplied-p var.
455 ;;; If present the supplied-p var is in a singleton list.
456 ;;; DEFAULT should be specified as '* when parsing a DEFTYPE lambda-list.
457 (defun parse-key-arg-spec (spec &optional default
)
459 (symbol (values (keywordicate spec
) spec default nil nil
))
460 (cons (destructuring-bind (var &optional
(def default defaultp
) . sup-p-var
)
463 (values (keywordicate var
) var def sup-p-var defaultp
)
464 (values (car var
) (cadr var
) def sup-p-var defaultp
))))))
466 ;;; Return a "twice abstracted" representation of DS-LAMBDA-LIST that removes
467 ;;; all variable names, &AUX parameters, supplied-p variables, and defaults.
468 ;;; The result is a list with trailing suffixes of NIL dropped, and which can
469 ;;; be given to an AST matcher yielding a boolean answer as to whether some
470 ;;; input matches, with one caveat: Destructured &OPTIONAL or &KEY default
471 ;;; forms may cause failure of a destructuring-bind due to inner expressions
472 ;;; causing mismatch. In most cases this can not be anticipated.
473 (defun meta-abstractify-ds-lambda-list (parsed-ds-lambda-list)
474 (labels ((process-opt/key
(x) (recurse (if (listp x
) (car x
) x
)))
476 (when (symbolp thing
)
477 (return-from recurse t
))
478 (with-ds-lambda-list-parts (llks whole req opt rest keys
) thing
480 (when (ll-kwds-keyp llks
)
481 (cons (ll-kwds-allowp llks
)
483 (cons (parse-key-arg-spec x
)
484 (if (typep x
'(cons cons
))
486 (process-opt/key x
))))
488 ;; Compute reversed representation of req, opt, rest.
489 (repr (list (when rest
(recurse (car rest
)))
490 (mapcar #'process-opt
/key opt
)
491 (mapcar #'recurse req
))))
492 ;; If &KEYS are present, then req, opt, rest must be too.
493 ;; But if not, then pop leading NILs (which become trailing
494 ;; NILs). Missing parts aren't stored.
495 ;; A degenerate ds-lambda-list accepting 0 args is just ().
497 (loop (if (or (null repr
) (car repr
)) (return) (pop repr
))))
498 (let ((result (nreconc repr keys
))
500 (if (vectorp whole
) ; Destructuring. Ugh.
501 ;; The input must match two things - a tree implied by
502 ;; the nested &WHOLE, and a tree that contains it.
503 `(:both
,(recurse whole
) ,@result
)
505 (recurse parsed-ds-lambda-list
)))
507 ;; Construct a lambda list from sublists.
508 ;; If &WHOLE and REST are present, they must be singleton lists.
509 ;; Any sublists that were obtained by parsing a destructuring
510 ;; lambda list must be supplied in their unparsed form.
511 (defun make-lambda-list (llks whole required
&optional optional rest keys aux
)
512 (append (when whole
(cons '&whole whole
))
514 (when (logtest (lambda-list-keyword-mask '&optional
) llks
)
515 (cons '&optional optional
))
516 (let ((restp (ll-kwds-restp llks
)))
517 (if (and rest
(not restp
)) ; lambda list was "dotted"
520 (when rest
(cons restp rest
))
521 (if (ll-kwds-keyp llks
) (cons '&key keys
)) ; KEYS can be nil
522 (if (ll-kwds-allowp llks
) '(&allow-other-keys
))
523 ;; Should &AUX be inserted even if empty? Probably not.
524 (if aux
(cons '&aux aux
)))))))
526 ;;; Produce a destructuring lambda list from its internalized representation,
527 ;;; excluding any parts that don't constrain the shape of the expected input.
528 ;;; &AUX, supplied-p vars, and defaults do not impose shape constraints.
529 (defun unparse-ds-lambda-list (parsed-lambda-list &key cache
(remove-defaults t
))
530 (cond ((symbolp parsed-lambda-list
) parsed-lambda-list
)
531 ((cdr (assq parsed-lambda-list
(cdr cache
))))
533 (with-ds-lambda-list-parts (llks whole req optional rest keys
)
535 (labels ((process-opt (spec)
538 (cons (recurse (car spec
)) (maybe-default spec
))))
539 (maybe-default (spec)
540 (let ((def (cdr spec
)))
541 (when (and def
(not remove-defaults
))
542 (list (car def
))))) ; Remove any supplied-p var.
543 (recurse (x) (unparse-ds-lambda-list x
:cache cache
))
544 (memoize (input output
)
545 (when cache
(push (cons input output
) (cdr cache
)))
551 ;; &WHOLE is omitted unless it destructures something.
552 (when (vectorp (car whole
)) (list (recurse (car whole
))))
553 (mapcar #'recurse req
)
554 (mapcar #'process-opt optional
)
555 (when rest
(list (recurse (car rest
))))
557 (if (typep x
'(cons cons
))
558 (cons (list (caar x
) (recurse (cadar x
)))
563 ;;; Return the list of variables bound by a destructuring lambda list.
564 ;;; One purpose for this is to help expand destructuring-bind using
565 ;;; a strategy that delivers values to an MV-BIND.
566 ;;; It would otherwise be difficult to wrap a condition handler
567 ;;; around only the binding creation forms and not the body
568 ;;; of the destructuring-bind. Consider e.g.
570 (DESTRUCTURING-BIND (A &OPTIONAL
(B 0) (C 'DEF
)) L
(DOER))
571 -
> (multiple-value-bind (a b c
)
572 (handler-bind ((error (lambda (c) (return-from somewhere
))))
573 (values (pop (the cons L
))
575 (cond ((endp L
) 'def
)
576 ((endp (cdr L
)) (car L
))
577 (t (error "Excess args")))))
580 (defun ds-lambda-list-variables (parsed-lambda-list &optional
(include-aux t
))
582 (labels ((recurse (x) (if (vectorp x
) (scan x
) (output x
)))
583 (copy (x) (dolist (elt x
) (recurse elt
)))
584 (suppliedp-var (spec) (if (cddr spec
) (output (third spec
))))
586 (with-ds-lambda-list-parts (nil whole req opt rest key aux
) parts
590 (cond ((symbolp x
) (output x
))
595 (cond ((symbolp x
) (output x
))
596 (t (let ((k (car x
)))
597 (if (symbolp k
) (output k
) (recurse (cadr k
)))
598 (suppliedp-var x
)))))
601 (output (if (symbolp x
) x
(car x
))))))))
602 (recurse parsed-lambda-list
)
605 ;;; Return T if OBJECT matches TEMPLATE, where TEMPLATE is a meta-abstractified
606 ;;; destructuring lambda list. Mnemonic: the arguments are like TYPEP.
607 ;;; [Indeed the AST could be a monstrous type specifier involving {CONS,AND,OR}
608 ;;; except for lambda lists that involve keywords.]
610 (defun ds-lambda-list-match-p (object template
)
611 (macrolet ((pop-template () '(pop (truly-the list template
)))
613 '(unless template
(return-from recurse
(null args
))))
615 '(return-from recurse nil
)))
616 ;; When a failure occurs, we could return all the way out, but that would
617 ;; mean establishing a dynamic exit. Instead let failure bubble up.
618 (labels ((recurse (template args
)
619 (accept) ; Exit if no required, optional, rest, key args.
620 (when (eq (car (truly-the list template
)) :both
)
622 (and (recurse (cadr template
) args
)
623 (recurse (cddr template
) args
))))
625 (dolist (subpat (pop-template)) ; For each required argument
626 (let ((arg (if (atom args
) (fail) (pop args
))))
627 (when (and (listp subpat
) (not (recurse subpat arg
)))
629 (accept) ; Exit if no optional, rest, key args.
631 (dolist (subpat (pop-template))
632 (let ((arg (cond ((not (listp args
)) (fail))
634 ;; Why not just return T now?
635 ;; Because destructured &REST maybe.
638 (return-from recurse t
)))
640 (when (and (listp subpat
) (not (recurse subpat arg
)))
642 (accept) ; Exit if no rest, key args.
643 ;; If REST is not a cons, that's fine - it's either T, meaning
644 ;; that it was present but not a pattern, or NIL, meaning
645 ;; absent, in which case &KEY must have been present,
646 ;; otherwise the preceding (ACCEPT) would have returned.
647 (let ((rest (pop-template)))
648 (when (and (consp rest
) (not (recurse rest args
)))
650 (when (null template
) ; No keys.
651 (return-from recurse t
))
652 ;; Now test all keywords against the allowed ones, even if
653 ;; &ALLOW-OTHER-KEYS was present. Any key's value might bind
654 ;; to a subpattern, and the lambda list could be insane as well:
655 ;; (&KEY ((:allow-other-keys (x)) '(foo)))
656 ;; where the value of :ALLOW-OTHER-KEYS must apparently
658 (prog ((allowp (if (pop template
) t
0)) seen-other
)
661 (return (or (not seen-other
) (eq allowp t
))))
662 (unless (listp args
) (return nil
))
663 (let* ((next (cdr args
))
665 (cell (assq key template
)))
666 (unless (consp next
) (return nil
))
669 (let ((pattern (cdr cell
)))
670 (when (and (listp pattern
)
671 (not (recurse pattern
(car next
))))
673 (when (and (eq key
:allow-other-keys
) (eql allowp
0))
674 (setq allowp
(if (car next
) t nil
)))
675 (setq args
(cdr next
)))
677 (recurse template object
))))
679 ;;; Return the AST that recognizes inputs matching DS-LAMBDA-LIST.
680 (defun ds-lambda-list-matcher (ds-lambda-list)
681 (meta-abstractify-ds-lambda-list (parse-ds-lambda-list ds-lambda-list
)))
683 ;;; Emit a form to test whether INPUT matches DS-LAMBDA-LIST.
684 ;;; It's up to this function to decide (perhaps based on policy)
685 ;;; how to generate the code. There are a few simple cases that avoid
686 ;;; function calls. Others could easily be added. e.g. a 2-list could be:
687 ;;; (TYPEP INPUT '(CONS T (CONS T NULL)))
688 (defun emit-ds-lambda-list-match (input ds-lambda-list
)
689 (let ((matcher (ds-lambda-list-matcher ds-lambda-list
)))
690 ;; To match exactly 1 required arg, use SINGLETON-P.
691 (cond ((equal matcher
'((t))) `(singleton-p ,input
))
692 ;; Matching 0 required, 0 optional, and rest is trivially T.
693 ((equal matcher
'(() () t
)) t
)
694 (t `(ds-lambda-list-match-p ,input
',matcher
)))))
696 ;;; Emit a correctness check for one level of structure in PARSED-LAMBDA-LIST
697 ;;; which receives values from INPUT.
698 ;;; MACRO-CONTEXT provides context for the diagnostic message.
699 ;;; MEMO-TABLE is an alist of previously-unparsed parsed-lambda-lists.
700 ;;; The checker returns INPUT if it was well-formed, or signals an error.
702 ;;; There is a better way (not implemented) to check &KEY arguments: assume
703 ;;; optimistically that unknown/duplicate keywords aren't frequent, and perform
704 ;;; all GETF operations for known keywords into temp vars; count the ones that
705 ;;; found something, and compare to the plist length/2. If not equal, then do
706 ;;; a further check. Otherwise we've done most of the work of parsing;
707 ;;; just move the temps into their final places in turn.
709 (defun emit-ds-bind-check (parsed-lambda-list input macro-context memo-table
)
710 (with-ds-lambda-list-parts (llks nil req opt rest keys
) parsed-lambda-list
711 (let* ((display (unparse-ds-lambda-list parsed-lambda-list
:cache memo-table
))
712 (pattern `',(if macro-context
(cons macro-context display
) display
))
714 (max (+ min
(length opt
)))
715 (bounds (list min max
)))
716 (cond ((ll-kwds-keyp llks
)
717 `(,(if (typep macro-context
718 '(cons t
(cons t
(eql define-compiler-macro
))))
719 'cmacro-check-ds-list
/&key
721 ,input
,@bounds
,pattern
722 ,(unless (ll-kwds-allowp llks
)
723 (map 'vector
#'parse-key-arg-spec keys
))))
724 ;; The case that need not check anything at all:
725 ;; no keys, no required, no optional, and a &rest arg.
726 ((and rest
(eql max
0)) input
) ; nothing to check
727 (rest `(check-ds-list/&rest
,input
,@bounds
,pattern
))
728 (t `(check-ds-list ,input
,@bounds
,pattern
))))))
730 ;;; Produce the binding clauses for a BINDING* form that destructures
731 ;;; LAMBDA-LIST from input in DATA.
732 ;;; EMIT-PRE-TEST, if true, will diagnose most (but not all) structural
733 ;;; errors [*] before executing user-supplied code in defaulting forms.
734 ;;; EXPLICIT-CAST is one of {THE, TRULY-THE, NIL} to insert casts or not.
735 ;;; Optional MACRO-CONTEXT provides context for the error strings.
736 ;;; DEFAULT-DEFAULT, which defaults to NIL, supplies the value for optional
737 ;;; and key arguments which were absent and had no explicit defaulting form.
739 ;;; Without explicit casts, the input must satisfy LISTP at each CAR/CDR step.
740 ;;; If pre-tests were done and user code did not smash the input, then it
741 ;;; will satisfy LISTP, and EXPLICIT-CAST may be specified as 'TRULY-THE
742 ;;; to omit compiler-generated ("checkgen") tests. If pre-tests were not done,
743 ;;; then EXPLICIT-CAST should be specified as 'THE to strengthen type tests
744 ;;; into (THE CONS x) at mandatory arguments.
746 ;;; [*] "Structural errors" are those due to mismatch of the input against
747 ;;; the template; in the case of one list level, an error can be signaled
748 ;;; before defaults are evaluated, but with nested destructuring, this is not
749 ;;; always possible. Previously there was an attempt to check outer lists
750 ;;; before proceeding to inner lists, but this required departure from
751 ;;; customary left-to-right evaluation order of source forms as written.
752 ;;; The new scheme seems more in accordance with other Lisp implementations.
753 ;;; Portable code should probably not rely on the order in which structural
754 ;;; errors are tested for. If input is well-formed - it matches the template -
755 ;;; then there is no possibility of user code sensing the order in which
756 ;;; well-formedness tests ran.
758 (defun expand-ds-bind (lambda-list data emit-pre-test explicit-cast
759 &optional macro-context default-default
)
760 (collect ((cache (list nil
)) ; This is a "scratchpad" for the unparser.
763 (;; Bind VAR from VAL-FORM. VAR can be a symbol or ds-lambda-list.
764 (bind-pat (var val-form
)
765 (if (symbolp var
) (bind `(,var
,val-form
)) (descend var val-form
)))
766 ;; Conditionally bind VAR from VAL-FORM based on SUP-P-FORM.
767 (bind-if (sense sup-p-form val-form var sup-p-var def
)
768 (let* ((suppliedp (car sup-p-var
)) ; could be nil
769 (vals (gen-test sense sup-p-form
770 (if sup-p-var
`(values ,val-form t
) val-form
)
772 (cond ((not sup-p-var
) (bind-pat var vals
))
773 ((symbolp var
) (bind `((,var
,suppliedp
) ,vals
)))
775 (let ((var-temp (sb!xc
:gensym
))
776 (sup-p-temp (copy-symbol suppliedp
)))
777 (bind `((,var-temp
,sup-p-temp
) ,vals
))
778 (descend var var-temp
)
779 (bind `(,suppliedp
,sup-p-temp
)))))))
780 (gen-test (sense test then else
)
781 (cond ((eq sense t
) `(if ,test
,then
,@(if else
(list else
))))
782 (else `(if ,test
,else
,then
)) ; flip the branches
783 (t `(if (not ,test
) ,then
)))) ; invert the test
784 (descend (parsed-lambda-list input
)
785 (with-ds-lambda-list-parts (llks whole required opt rest keys aux
)
787 ;; There could be nothing but &AUX vars in the lambda list.
788 ;; If nothing to bind from INPUT, then ignore "ds-check" result.
789 ;; But if keywords are accepted, always call the checker.
790 ;; A feature of BINDING* is that binding something to () means,
791 ;; in theory, (MULTIPLE-VALUE-BIND () (EXPR) ...)
792 ;; but in practice it becomes a binding of an ignored gensym.
793 (let* ((bindings-p (or whole required opt rest keys
))
794 (temp (and bindings-p
(sb!xc
:gensym
))))
796 ,(cond ((or emit-pre-test
(ll-kwds-keyp llks
))
797 (emit-ds-bind-check parsed-lambda-list input
798 macro-context
(cache)))
799 ((or bindings-p
(not explicit-cast
)) input
)
800 ;; If nothing gets bound, then input must be NIL,
801 ;; unless &KEY is accepted, which was done above.
802 (t `(,explicit-cast null
,input
)))))
804 ;; I would think it totally absurd to use something
805 ;; other than a symbol for &WHOLE, but the spec allows it.
806 (when whole
(bind-pat (car whole
) input
))
808 (flet ((cast/pop
(typed-list-expr more-to-go
)
809 `(prog1 (car ,typed-list-expr
)
810 ,(if (or more-to-go rest
(ll-kwds-keyp llks
))
811 `(setq ,input
(cdr ,input
))
812 `(,explicit-cast null
(cdr ,input
))))))
813 ;; Mandatory args. Only the rightmost need check that it sees
814 ;; a CONS. The predecessors will naturally assert that the
815 ;; input so far was of type LIST, which is enough.
816 (do ((elts required
(cdr elts
)))
820 (cast/pop
`(,explicit-cast
821 ,(if (cdr elts
) 'list
'cons
) ,input
)
825 (do ((elts opt
(cdr elts
)))
827 (multiple-value-bind (var def sup-p-var
)
828 (parse-optional-arg-spec (car elts
) default-default
)
831 (cast/pop
`(,explicit-cast list
,input
)
834 var sup-p-var def
))))
836 ;; The spec allows the inane use of (A B &REST (C D)) = (A B C D).
837 ;; The former is less efficient, since it is "nested", only not.
838 (when rest
(bind-pat (car rest
) input
))
842 (multiple-value-bind (keyword var def sup-p-var
)
843 (parse-key-arg-spec elt default-default
)
844 (let ((temp (sb!xc
:gensym
)))
845 (bind `(,temp
(ds-getf ,input
',keyword
)))
846 (bind-if :not
`(eql ,temp
0) `(car (truly-the cons
,temp
))
847 var sup-p-var def
))))
849 ;; &AUX bindings aren't destructured. Finally something easy.
851 (multiple-value-bind (var val
)
852 (if (listp elt
) (values (car elt
) (cadr elt
)) elt
)
853 (bind `(,var
,val
)))))))
855 (descend (parse-ds-lambda-list lambda-list
) data
)
860 ;; Given FORM as the input to a compiler-macro, return the argument forms
861 ;; that the called function would receive, skipping over FUNCALL.
862 (defun compiler-macro-args (form)
863 (cdr (if (eql (car form
) 'funcall
) (cdr form
) form
)))
865 ;; Extract the context from a destructuring-bind pattern as represented in
866 ;; a call to a checking function. A "context" is a non-bindable subpattern
867 ;; headed by :MACRO (if it came from any macro-like thing, e.g. DEFTYPE),
869 ;; Return three values: CONTEXT-NAME, CONTEXT-KIND, and the real pattern.
870 (defun get-ds-bind-context (pattern)
871 (let ((marker (car pattern
)))
872 (case (and (listp marker
) (car marker
))
874 (let ((context (cdr marker
)))
875 (values (car context
) (cdr context
) (cdr pattern
))))
877 (values (cdr marker
) :special-form
(cdr pattern
)))
879 (values nil
:eval
(cdr pattern
)))
881 (values nil
'destructuring-bind pattern
)))))
883 ;;; Helpers for the variations on CHECK-DS-mumble.
884 (defun ds-bind-error (input min max pattern
)
885 (multiple-value-bind (name kind lambda-list
) (get-ds-bind-context pattern
)
887 (declare (optimize allow-non-returning-tail-call
))
890 ;; IR1 translators should call COMPILER-ERROR instead of
891 ;; ERROR. To ingrain that knowledge into the CHECK-DS-foo
892 ;; functions is a bit of a hack, but to do otherwise
893 ;; changes how DS-BIND has to expand.
894 (compiler-error 'sb
!kernel
::arg-count-error
895 :kind
"special operator" :name name
896 :args input
:lambda-list lambda-list
897 :minimum min
:maximum max
))
900 (error 'sb
!eval
::arg-count-program-error
901 ;; This is stupid. Maybe we should just say
902 ;; "error parsing special form"?
903 ;; It would be more sensible than mentioning
904 ;; a random nonstandard macro.
905 :kind
'sb
!eval
::program-destructuring-bind
906 :args input
:lambda-list lambda-list
907 :minimum min
:maximum max
))
909 (error 'sb
!kernel
::arg-count-error
910 :kind kind
:name name
911 :args input
:lambda-list lambda-list
912 :minimum min
:maximum max
)))))
914 (defun check-ds-bind-keys (input plist valid-keys pattern
)
915 ;; Check just the keyword portion of the input in PLIST
916 ;; against VALID-KEYS. If VALID-KEYS = NIL then we don't care what
917 ;; the keys are - &ALLOW-OTHER-KEYS was present in the lambda-list,
918 ;; and we don't care if non-symbols are found in keyword position.
919 ;; Always enforce that the list has even length though.
920 (let* (seen-allowp seen-other bad-key
926 (return :unknown-keyword
)
927 (return-from check-ds-bind-keys input
)))
928 (unless (listp tail
) (return :dotted-list
))
929 (let ((next (cdr tail
)))
930 (when (null next
) (return :odd-length
))
931 (unless (listp next
) (return :dotted-list
))
932 (let ((key (car tail
)))
934 (if (eq key
:allow-other-keys
) ; always itself allowed
937 (when (car next
) ; :allow-other-keys <non-nil>
938 (setf seen-other nil valid-keys nil
)))
939 (unless (or seen-other
940 (find key
(truly-the simple-vector valid-keys
)
942 (setq seen-other t bad-key key
)))))
943 (setq tail
(cdr next
))))))
944 (multiple-value-bind (kind name
) (get-ds-bind-context pattern
)
946 (declare (optimize allow-non-returning-tail-call
))
947 ;; KLUDGE: Compiling (COERCE x 'list) transforms to COERCE-TO-LIST,
948 ;; but COERCE-TO-LIST is an inline function not yet defined, and
949 ;; its subsequent definition would signal an inlining failure warning.
950 (declare (notinline coerce
))
951 (error 'sb
!kernel
::defmacro-lambda-list-broken-key-list-error
952 :kind kind
:name name
954 :info
(if (eq problem
:unknown-keyword
)
955 ;; show any one unaccepted keyword
956 (list bad-key
(coerce valid-keys
'list
))
959 (macrolet ((scan-req-opt ((input min max pattern list-name actual-max
)
960 &key if-list-exhausted if-max-reached
)
961 ;; Decide whether the input matches up to the end of
962 ;; the required and/or optional arguments.
963 ;; MAX is the limit on number of CDR operations performed
964 ;; in the loop. ACTUAL-MAX describes the upper bound
965 ;; in a condition reporting function.
966 ;; e.g. (A &OPTIONAL B &REST C) has MAX = 2, ACTUAL-MAX = NIL.
967 ;; The input must be a proper list up to 2 arguments,
968 ;; but beyond that may be dotted.
969 `(let ((,list-name
,input
) (count ,max
))
970 (declare (type index count
))
971 (loop (when (zerop count
) (return ,if-max-reached
))
972 (when (null ,list-name
)
974 (if (< (- max count
) ,min
)
975 (ds-bind-error ,input
,min
,actual-max
,pattern
)
976 ,if-list-exhausted
)))
977 (unless (listp ,list-name
) ; dotted list error
979 (ds-bind-error ,input
,min
,actual-max
,pattern
)))
981 (setq ,list-name
(cdr ,list-name
))))))
983 ;; Assert that INPUT has the requisite number of elements as
984 ;; specified by MIN/MAX. PATTERN does not contain &REST or &KEY.
985 (defun check-ds-list (input min max pattern
)
986 (declare (type index min max
) (optimize speed
))
987 (scan-req-opt (input min max pattern list max
)
988 ;; If 'count' became zero, then since there was
989 ;; no &REST, the LIST had better be NIL.
991 (if list
(ds-bind-error input min max pattern
) input
)
992 ;; The loop checks for dotted tail and >= MIN elements,
993 ;; so end of list means a valid match to the pattern.
994 :if-list-exhausted input
))
996 ;; As above, but the pattern contains &REST.
997 ;; Elements beyond the final optional arg can form a dotted list.
998 (defun check-ds-list/&rest
(input min max pattern
)
999 (declare (type index min max
) (optimize speed
))
1000 (scan-req-opt (input min max pattern list nil
)
1001 :if-list-exhausted input
:if-max-reached input
))
1003 ;; The pattern contains &KEY. Anything beyond the final optional arg
1004 ;; must be a well-formed property list regardless of existence of &REST.
1005 (defun check-ds-list/&key
(input min max pattern valid-keys
)
1006 (declare (type index min max
) (optimize speed
))
1007 (scan-req-opt (input min max pattern list nil
)
1008 :if-list-exhausted input
1009 :if-max-reached
(check-ds-bind-keys
1010 input list valid-keys pattern
)))
1012 ;; Compiler-macro lambda lists are macro lambda lists -- meaning that
1013 ;; &key ((a a) t) should match a literal A, not a form evaluating to A
1014 ;; as in an ordinary lambda list.
1016 ;; That, however, breaks the evaluation model unless A is also a
1017 ;; constant evaluating to itself. So, signal a condition telling the
1018 ;; compiler to punt on the expansion.
1019 ;; Moreover it has to be assumed that any non-constant might
1020 ;; evaluate to :ALLOW-OTHER-KEYS.
1022 ;; The reason this is its own function is for separation of concerns.
1023 ;; Suppose that CHECK-DS-LIST/&KEY had a short-circuit exit wherein
1024 ;; seeing ":ALLOW-OTHER-KEYS <non-nil>" stopped testing for keywords in
1025 ;; the accepted list, but instead quickly scanned for a proper tail.
1026 ;; (It doesn't, but suppose it did). A compiler-macro must nonetheless
1027 ;; finish looking for all non-constant symbols in keyword positions.
1028 ;; More realistically, if the optimization for &KEY mentioned above
1029 ;; EMIT-DS-BIND-CHECK were implemented, where perhaps we elide a call
1030 ;; to validate keywords, a compiler-macro is probably always best
1031 ;; handled by a out-of-line call on account of the extra hair.
1033 (defun cmacro-check-ds-list/&key
(input min max pattern valid-keys
)
1034 (declare (type index min max
) (optimize speed
))
1035 (scan-req-opt (input min max pattern list nil
)
1036 :if-list-exhausted input
1038 ;; Signal a condition if the compiler should give up
1039 ;; on expanding. Well-formedness of the plist
1040 ;; makes no difference, since CHECK-DS-BIND-KEYS is stricter.
1041 ;; If the condition isn't handled, we just press onward.
1043 (loop (when (atom plist
) (return))
1044 (let ((key (pop plist
)))
1045 (when (atom plist
) (return))
1047 (unless (or (keywordp key
)
1050 (eq key
(symbol-value key
))))
1051 (signal 'compiler-macro-keyword-problem
1053 (check-ds-bind-keys input list valid-keys pattern
)))))
1055 ;; Like GETF but return CDR of the cell whose CAR contained the found key,
1056 ;; instead of CADR; and return 0 for not found.
1057 ;; This helps destructuring-bind slightly by avoiding a secondary value as a
1058 ;; found/not-found indicator, and using 0 is better for backends which don't
1059 ;; wire a register to NIL. Also, NIL would accidentally allow taking its CAR
1060 ;; if the caller were to try, whereas we'd want to see a explicit error.
1061 (defun ds-getf (place indicator
)
1062 (do ((plist place
(cddr plist
)))
1064 (cond ((atom (cdr plist
))
1065 (error 'simple-type-error
1066 :format-control
"malformed property list: ~S."
1067 :format-arguments
(list place
)
1069 :expected-type
'cons
))
1070 ((eq (car plist
) indicator
)
1071 ;; Typecheck the next cell so that calling code doesn't get an atom.
1072 (return (the cons
(cdr plist
)))))))
1074 ;;; Make a lambda expression that receives an s-expression, destructures it
1075 ;;; according to LAMBDA-LIST, and executes BODY.
1076 ;;; NAME and KIND provide error-reporting context.
1077 ;;; DOC-STRING-ALLOWED can be :INTERNAL to allow a docstring which is kept
1078 ;;; inside the lambda, or :EXTERNAL to pull it out and return it, or NIL.
1079 ;;; ENVIRONMENT can be NIL to disallow an &ENVIRONMENT variable,
1080 ;;; or :IGNORE to allow it, but bind the corresponding symbol to NIL.
1081 ;;; WRAP-BLOCK, if true, will place a block named NAME around body.
1083 ;;; The secondary value is a docstring, if requested as :EXTERNAL.
1085 ;;; The lambda contains an internal declaration of its argument list
1086 ;;; that discards &ENVIRONMENT, &WHOLE, and/or anything else that does
1087 ;;; not document the expected list shape.
1089 ;;; The CLtl2 name for this operation is PARSE-MACRO.
1090 (defun make-macro-lambda
1091 (lambda-name lambda-list body kind name
1092 &key
(accessor 'cdr
) (doc-string-allowed :internal
)
1093 ((:environment envp
) t
) (wrap-block name
))
1094 (declare (type (member t nil
:ignore
) envp
))
1095 (declare (type (member nil
:external
:internal
) doc-string-allowed
))
1096 (binding* (((forms decls docstring
) (parse-body body doc-string-allowed
))
1097 ;; Parse the lambda list, but not recursively.
1098 ((llks req opt rest keys aux env whole
)
1102 (if envp
(lambda-list-keyword-mask '&environment
) 0)
1103 (lambda-list-keyword-mask 'destructuring-bind
))
1104 ;; Why :silent? We first parse to deconstruct and reconstruct
1105 ;; without &WHOLE and &ENV, which is an implementation detail.
1106 ;; When it comes to actually processing the entire lambda
1107 ;; list again, that's when any warning(s) will be issued.
1108 :context
:macro
:silent t
))
1109 ((outer-decls decls
) (extract-var-decls decls
(append env whole
)))
1110 (ll-env (when (eq envp t
) (or env
(list (make-symbol "ENV")))))
1111 ;; We want a hidden WHOLE arg for the lambda - not the user's -
1112 ;; in case one was present and declared IGNORE.
1113 ;; Conversely, if the user asks for &WHOLE, doesn't use it,
1114 ;; and doesn't declare it ignored, that deserves a warning.
1115 (ll-whole (make-symbol "EXPR"))
1116 ;; Then bind the user's WHOLE from the lambda's.
1118 (append (when (and (eq envp
:ignore
) env
) `((,(car env
) nil
)))
1119 (when whole
`((,(car whole
) ,ll-whole
)))))
1120 ;; Drop &WHOLE and &ENVIRONMENT
1121 (new-ll (make-lambda-list llks nil req opt rest keys aux
))
1122 (parse (parse-ds-lambda-list new-ll
))
1123 ((declared-lambda-list decls
)
1125 (loop for
(nil . declarations
) in decls
1127 (loop for x in declarations
1129 (eql (car x
) 'lambda-list
))
1133 ;; Normalize the lambda list by unparsing.
1134 `(lambda-list ,(unparse-ds-lambda-list parse
:remove-defaults nil
)))
1136 (loop for
(declare . declarations
) in decls
1137 collect
(list* declare
1138 (remove 'lambda-list declarations
:key
#'car
)))
1140 ;; Signal a style warning for duplicate names, but disregard &AUX variables
1141 ;; because most folks agree that (LET* ((X (F)) (X (G X))) ..) makes sense
1142 ;; - some would even say that it is idiomatic - and &AUX bindings are just
1144 ;; The obsolete PARSE-DEFMACRO signaled an error, but that seems harsh.
1145 ;; Other implementations permit (X &OPTIONAL X),
1146 ;; and the allowance for nesting makes this issue even less clear.
1147 (mapl (lambda (tail)
1148 (when (memq (car tail
) (cdr tail
))
1149 (style-warn-once lambda-list
"variable ~S occurs more than once"
1151 (append whole env
(ds-lambda-list-variables parse nil
)))
1152 ;; Maybe kill docstring, but only under the cross-compiler.
1153 #!+(and (not sb-doc
) (host-feature sb-xc-host
)) (setq docstring nil
)
1154 (values `(,@(if lambda-name
`(named-lambda ,lambda-name
) '(lambda))
1155 (,ll-whole
,@ll-env
,@(and ll-aux
(cons '&aux ll-aux
)))
1156 ,@(when (and docstring
(eq doc-string-allowed
:internal
))
1157 (prog1 (list docstring
) (setq docstring nil
)))
1158 ;; MACROLET doesn't produce an object capable of reflection,
1159 ;; so don't bother inserting a different lambda-list.
1160 ,@(unless (eq kind
'macrolet
)
1162 `((declare ,declared-lambda-list
)))
1163 ,@(if outer-decls
(list outer-decls
))
1164 ,@(and (not env
) (eq envp t
) `((declare (ignore ,@ll-env
))))
1165 ,@(sb!c
:macro-policy-decls
)
1167 `(named-ds-bind ,(if (eq kind
:special-form
)
1168 `(:special-form .
,name
)
1169 `(:macro
,name .
,kind
)))
1170 '(destructuring-bind))
1171 ,new-ll
(,accessor
,ll-whole
)
1174 `((block ,(fun-name-block-name name
) ,@forms
))
1178 ;;; Functions should probably not retain &AUX variables as part
1179 ;;; of their reflected lambda list, but this is selectable
1180 ;;; because some users might claim that dropping &AUX is wrong.
1181 ;;; For system code, it's a measurably large waste of space,
1182 ;;; given how DEFTRANSFORM and a few other macros expand such
1183 ;;; that argument parsing is performed in &AUX var initforms.
1184 (defvar *strip-lamba-list-retain-aux
* #+sb-xc t
#-sb-xc nil
)
1186 ;;; Return LAMBDA-LIST with some pieces removed.
1187 (defun strip-lambda-list (lambda-list how
)
1188 (handler-case (parse-lambda-list lambda-list
:silent t
)
1189 (error () lambda-list
)
1190 (:no-error
(llks req opt rest keys aux
&rest ignore
)
1191 (declare (ignore ignore
))
1192 (multiple-value-bind (opt keys aux
)
1195 (values opt keys
(if *strip-lamba-list-retain-aux
* aux nil
)))
1196 ;; The name of an anonymous lambda is an arbitrary list,
1197 ;; not necessarily the original list.
1198 (:name
(values (mapcar #'parse-optional-arg-spec opt
); Keep name.
1199 (mapcar #'parse-key-arg-spec keys
) ; Keep keyword.
1200 nil
))) ; Discard &AUX vars
1201 (let ((new (make-lambda-list llks nil req opt rest keys aux
)))
1202 ;; It is harmful to the space-saving effect of this function
1203 ;; if reconstituting the list results in an unnecessary copy.
1204 (if (equal new lambda-list
) lambda-list new
))))))
1206 (/show0
"parse-lambda-list.lisp end of file")