1 (in-package :alexandria
)
3 (defmacro with-gensyms
(names &body forms
)
4 "Binds each variable named by a symbol in NAMES to a unique symbol around
5 FORMS. Each of NAMES must either be either a symbol, or of the form:
7 (symbol string-designator)
9 Bare symbols appearing in NAMES are equivalent to:
13 The string-designator is used as the argument to GENSYM when constructing the
14 unique symbol the named variable will be bound to."
15 `(let ,(mapcar (lambda (name)
16 (multiple-value-bind (symbol string
)
19 (values name
(symbol-name name
)))
20 ((cons symbol
(cons string-designator null
))
21 (values (first name
) (string (second name
)))))
22 `(,symbol
(gensym ,string
))))
26 (defmacro with-unique-names
(names &body forms
)
27 "Alias for WITH-GENSYMS."
28 `(with-gensyms ,names
,@forms
))
30 (defmacro once-only
(specs &body forms
)
31 "Each SPEC must be either a NAME, or a (NAME INITFORM), with plain
32 NAME using the named variable as initform.
34 Evaluates FORMS with names rebound to temporary variables, ensuring
35 that each is evaluated only once.
38 (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
39 (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
40 (let ((gensyms (make-gensym-list (length specs
) "ONCE-ONLY"))
41 (names-and-forms (mapcar (lambda (spec)
44 (destructuring-bind (name form
) spec
50 `(let ,(mapcar (lambda (g n
) (list g
`(gensym ,(string (car n
)))))
51 gensyms names-and-forms
)
52 ;; bind in final expansion
53 `(let (,,@(mapcar (lambda (g n
)
55 gensyms names-and-forms
))
57 ,(let ,(mapcar (lambda (n g
) (list (car n
) g
))
58 names-and-forms gensyms
)
61 (defun parse-body (body &key documentation whole
)
62 "Parses BODY into (values remaining-forms declarations doc-string).
63 Documentation strings are recognized only if DOCUMENTATION is true.
64 Syntax errors in body are signalled and WHOLE is used in the signal
65 arguments when given."
71 (setf current
(car body
))
72 (when (and documentation
(stringp current
) (cdr body
))
74 (error "Too many documentation strings in ~S." (or whole body
))
75 (setf doc
(pop body
)))
77 (when (and (listp current
) (eql (first current
) 'declare
))
78 (push (pop body
) decls
)
80 (values body
(nreverse decls
) doc
)))
82 (defun parse-ordinary-lambda-list (lambda-list &key
(normalize t
)
84 (normalize-optional normalize
)
85 (normalize-keyword normalize
)
86 (normalize-auxilary normalize
))
87 "Parses an ordinary lambda-list, returning:
89 \(values requireds optionals rest keywords allow-other-keys? auxiliaries)
91 1. Required parameters.
92 2. Optional parameter specifications, normalized into form (NAME INIT SUPPLIEDP)
93 where SUPPLIEDP is NIL if not present.
94 3. Name of the rest parameter, or NIL.
95 4. Keyword parameter specifications, normalized into form ((KEYWORD-NAME NAME) INIT SUPPLIEDP)
96 where SUPPLIEDP is NIL if not present.
97 5. Boolean indicating &ALLOW-OTHER-KEYS presence.
98 6. &AUX parameter specifications, normalized into form (NAME INIT).
100 Signals a PROGRAM-ERROR is the lambda-list is malformed."
101 (let ((state :required
)
102 (allow-other-keys nil
)
110 (simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S"
112 (check-variable (elt what
&optional
(allow-specializers allow-specializers
))
113 (unless (and (or (symbolp elt
)
114 (and allow-specializers
115 (consp elt
) (= 2 (length elt
)) (symbolp (first elt
))))
116 (not (constantp elt
)))
117 (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S"
118 what elt lambda-list
)))
119 (check-spec (spec what
)
120 (destructuring-bind (init suppliedp
) spec
121 (declare (ignore init
))
122 (check-variable suppliedp what nil
))))
123 (dolist (elt lambda-list
)
126 (if (eq state
:required
)
130 (if (member state
'(:required
&optional
))
134 (if (member state
'(:required
&optional
:after-rest
))
139 (setf allow-other-keys t
143 (cond ((eq state
'&rest
)
146 (simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S"
153 (when (member elt
'#.
(set-difference lambda-list-keywords
154 '(&optional
&rest
&key
&allow-other-keys
&aux
)))
155 (simple-program-error
156 "Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S"
160 (check-variable elt
"required parameter")
164 (destructuring-bind (name &rest tail
) elt
165 (check-variable name
"optional parameter")
167 (check-spec tail
"optional-supplied-p parameter"))
169 (setf elt
(append elt
'(nil)))))))
171 (check-variable elt
"optional parameter")
172 (when normalize-optional
173 (setf elt
(cons elt
'(nil nil
))))))
174 (push (ensure-list elt
) optional
))
176 (check-variable elt
"rest parameter")
181 (destructuring-bind (var-or-kv &rest tail
) elt
182 (cond ((consp var-or-kv
)
183 (destructuring-bind (keyword var
) var-or-kv
184 (unless (symbolp keyword
)
185 (simple-program-error "Invalid keyword name ~S in ordinary ~
187 keyword lambda-list
))
188 (check-variable var
"keyword parameter")))
190 (check-variable var-or-kv
"keyword parameter")
191 (when normalize-keyword
192 (setf var-or-kv
(list (make-keyword var-or-kv
) var-or-kv
)))))
194 (check-spec tail
"keyword-supplied-p parameter")
195 (when normalize-keyword
196 (setf tail
(append tail
'(nil)))))
197 (setf elt
(cons var-or-kv tail
))))
199 (check-variable elt
"keyword parameter")
200 (setf elt
(if normalize-keyword
201 (list (list (make-keyword elt
) elt
) nil nil
)
206 (destructuring-bind (var &optional init
) elt
207 (declare (ignore init
))
208 (check-variable var
"&aux parameter"))
210 (check-variable elt
"&aux parameter")
211 (setf elt
(list* elt
(when normalize-auxilary
215 (simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list
)))))))
216 (values (nreverse required
) (nreverse optional
) rest
(nreverse keys
)
217 allow-other-keys
(nreverse aux
))))