/[cmucl]/src/code/defmacro.lisp
ViewVC logotype

Contents of /src/code/defmacro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (hide annotations)
Tue Apr 20 17:57:44 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.39: +20 -20 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ram 1.1 ;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.12 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 rtoy 1.40 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/defmacro.lisp,v 1.40 2010/04/20 17:57:44 rtoy Rel $")
9 ram 1.12 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12 wlott 1.3 ;;; Written by Blaine Burks.
13 ram 1.1 ;;;
14 wlott 1.3 (in-package "LISP")
15    
16 rtoy 1.38 (intl:textdomain "cmucl")
17    
18 wlott 1.3
19     ;;;; Some variable definitions.
20    
21     ;;; Variables for amassing the results of parsing a defmacro. Declarations
22     ;;; in DEFMACRO are the reason this isn't as easy as it sounds.
23 ram 1.1 ;;;
24 wlott 1.3 (defvar *arg-tests* ()
25 rtoy 1.39 "A list of tests that do argument counting at expansion time.")
26 ram 1.1
27 wlott 1.3 (defvar *system-lets* ()
28 rtoy 1.39 "Let bindings that are done to make lambda-list parsing possible.")
29 ram 1.1
30 wlott 1.3 (defvar *user-lets* ()
31 rtoy 1.39 "Let bindings that the user has explicitly supplied.")
32 ram 1.1
33 wlott 1.3 (defvar *default-default* nil
34 rtoy 1.39 "Unsupplied optional and keyword arguments get this value defaultly.")
35 ram 1.1
36 ram 1.19 ;; Temps that we introduce and might not reference.
37     (defvar *ignorable-vars*)
38    
39    
40 wlott 1.3
41     ;;;; Stuff to parse DEFMACRO, MACROLET, DEFINE-SETF-METHOD, and DEFTYPE.
42    
43     ;;; PARSE-DEFMACRO returns, as multiple-values, a body, possibly a declare
44     ;;; form to put where this code is inserted, and the documentation for the
45     ;;; parsed body.
46 ram 1.1 ;;;
47 wlott 1.3 (defun parse-defmacro (lambda-list arg-list-name code name error-kind
48     &key (annonymousp nil)
49     (doc-string-allowed t)
50     ((:environment env-arg-name))
51     ((:default-default *default-default*))
52 wlott 1.6 (error-fun 'error))
53 rtoy 1.39 "Returns as multiple-values a parsed body, any local-declarations that
54 wlott 1.3 should be made where this body is inserted, and a doc-string if there is
55     one."
56     (multiple-value-bind (body declarations documentation)
57     (parse-body code nil doc-string-allowed)
58     (let* ((*arg-tests* ())
59     (*user-lets* ())
60 ram 1.19 (*system-lets* ())
61     (*ignorable-vars* ()))
62 wlott 1.3 (multiple-value-bind
63     (env-arg-used minimum maximum)
64     (parse-defmacro-lambda-list lambda-list arg-list-name name
65 wlott 1.4 error-kind error-fun (not annonymousp)
66 wlott 1.3 nil env-arg-name)
67     (values
68     `(let* ,(nreverse *system-lets*)
69 ram 1.19 ,@(when *ignorable-vars*
70     `((declare (ignorable ,@*ignorable-vars*))))
71 wlott 1.3 ,@*arg-tests*
72     (let* ,(nreverse *user-lets*)
73     ,@declarations
74     ,@body))
75 ram 1.19 `(,@(when (and env-arg-name (not env-arg-used))
76     `((declare (ignore ,env-arg-name)))))
77 wlott 1.3 documentation
78     minimum
79     maximum)))))
80 ram 1.1
81 gerd 1.30 (defun restify-dotted-lambda-list (lambda-list)
82     (collect ((new))
83     (do ((tail lambda-list (cdr tail)))
84     ((atom tail) (progn
85     (unless (null tail) (new '&rest tail))
86     (new)))
87     (new (car tail)))))
88 ram 1.1
89 rtoy 1.36 #+nil
90 gerd 1.32 (declaim (inline dotted-list-length))
91 rtoy 1.36 ;;; FIXME: Remove this later! This was left here to make
92     ;;; bootstrapping list-length-bounded-p easier.
93 gerd 1.31 (defun dotted-list-length (list)
94 emarsden 1.34 ;; this is a workaround for spurious efficiency notes when compiling
95     ;; DEFTYPE declarations in code under high optimization
96     (declare (optimize (ext:inhibit-warnings 3)))
97 gerd 1.31 (loop for tail on list until (atom tail) count t))
98    
99 rtoy 1.36
100     (declaim (inline list-length-bounded-p))
101     (defun list-length-bounded-p (list min &optional max)
102     ;; this is a workaround for spurious efficiency notes when compiling
103     ;; DEFTYPE declarations in code under high optimization
104     (declare (optimize (ext:inhibit-warnings 3)))
105     (let ((limit (if max max min)))
106     (do ((tail list (cdr tail))
107     (count 0 (1+ count)))
108     ((or (atom tail)
109     (>= count limit))
110     ;; If MAX was given, we better be at end of list and have
111     ;; length at least MIN. Otherwise, we just need to make sure
112     ;; the length is at least MIN.
113     (if max
114     (and (atom tail) (<= min count))
115     (<= min count))))))
116    
117 wlott 1.4 (defun parse-defmacro-lambda-list
118     (lambda-list arg-list-name name error-kind error-fun
119     &optional top-level env-illegal env-arg-name)
120 wlott 1.3 (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name))
121 gerd 1.30 (lambda-list (restify-dotted-lambda-list lambda-list))
122 wlott 1.3 (now-processing :required)
123     (maximum 0)
124     (minimum 0)
125     (keys ())
126 gerd 1.26 (key-seen nil)
127 wlott 1.3 rest-name restp allow-other-keys-p env-arg-used)
128 gerd 1.30 (when (and (member '&whole lambda-list)
129 wlott 1.3 (not (eq (car lambda-list) '&whole)))
130 rtoy 1.40 (simple-program-error (intl:gettext "&Whole must appear first in ~S lambda-list.")
131 pmai 1.22 error-kind))
132 wlott 1.3 (do ((rest-of-args lambda-list (cdr rest-of-args)))
133 gerd 1.30 ((null rest-of-args))
134 wlott 1.3 (let ((var (car rest-of-args)))
135     (cond ((eq var '&whole)
136     (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
137     (setf rest-of-args (cdr rest-of-args))
138 toy 1.21 ;; For compiler macros, we have to do something
139     ;; special in case the form has a car eq to
140     ;; funcall, as specified in the CLHS. In this
141     ;; case, we skip over the funcall and pretend
142     ;; that the rest of the form is the actual form.
143     ;;
144     ;; This is a gross hack because we look at
145     ;; error-kind to figure out if we're defining a
146     ;; compiler macro or not.
147     (when (eq error-kind 'define-compiler-macro)
148     (push-let-binding arg-list-name arg-list-name
149     t
150     `(progn
151     (not (and (listp ,arg-list-name)
152     (eq 'funcall (car ,arg-list-name)))))
153     `(progn
154     (setf ,arg-list-name (cdr ,arg-list-name)))))
155 wlott 1.3 (push-let-binding (car rest-of-args) arg-list-name nil))
156 gerd 1.25 ((and (cdr rest-of-args) (consp (cadr rest-of-args)))
157     (pop rest-of-args)
158     (let* ((destructuring-lambda-list (car rest-of-args))
159     (sub (gensym "WHOLE-SUBLIST")))
160     (push-sub-list-binding
161     sub arg-list-name destructuring-lambda-list
162     name error-kind error-fun)
163     (parse-defmacro-lambda-list
164     destructuring-lambda-list sub name error-kind error-fun)))
165 wlott 1.3 (t
166 wlott 1.6 (defmacro-error "&WHOLE" error-kind name))))
167 wlott 1.3 ((eq var '&environment)
168     (cond (env-illegal
169 rtoy 1.40 (simple-program-error (intl:gettext "&environment not valid with ~S.")
170 pmai 1.22 error-kind))
171 wlott 1.3 ((not top-level)
172 pmai 1.22 (simple-program-error
173 rtoy 1.40 (intl:gettext "&environment only valid at top level of lambda-list."))))
174 wlott 1.3 (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
175     (setf rest-of-args (cdr rest-of-args))
176 gerd 1.27 (append-let-binding (car rest-of-args) env-arg-name nil)
177 wlott 1.3 (setf env-arg-used t))
178     (t
179 wlott 1.6 (defmacro-error "&ENVIRONMENT" error-kind name))))
180 gerd 1.25 ;;
181     ;; This branch implements an extension to Common Lisp
182     ;; that was formerly implemented for &body. In place of
183     ;; a symbol following &body, there could be a list of up
184     ;; to three elements which will be bound to the body,
185     ;; declarations, and doc-string of the body.
186     ((eq var '&parse-body)
187     (unless (and (cdr rest-of-args)
188     (consp (cadr rest-of-args))
189     (symbolp (caadr rest-of-args)))
190 rtoy 1.40 (simple-program-error (intl:gettext "Invalid ~a") '&parse-body))
191 gerd 1.25 (setf rest-of-args (cdr rest-of-args))
192     (setf restp t)
193     (let ((body-name (caar rest-of-args))
194     (declarations-name (cadar rest-of-args))
195     (doc-string-name (caddar rest-of-args))
196     (parse-body-values (gensym)))
197     (push-let-binding
198     parse-body-values
199     `(multiple-value-list
200     (parse-body ,path ,env-arg-name
201     ,(not (null doc-string-name))))
202     t)
203     (setf env-arg-used t)
204     (when body-name
205     (push-let-binding body-name
206     `(car ,parse-body-values) nil))
207     (when declarations-name
208     (push-let-binding declarations-name
209     `(cadr ,parse-body-values) nil))
210     (when doc-string-name
211     (push-let-binding doc-string-name
212     `(caddr ,parse-body-values) nil))))
213     ;;
214     ((member var '(&rest &body))
215 toy 1.23 (cond ((and (cddr rest-of-args)
216     (not (member (caddr rest-of-args) lambda-list-keywords)))
217     (defmacro-error (symbol-name var) error-kind name))
218     ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
219 wlott 1.3 (setf rest-of-args (cdr rest-of-args))
220     (setf restp t)
221     (push-let-binding (car rest-of-args) path nil))
222 gerd 1.25 ((and (cdr rest-of-args) (consp (cadr rest-of-args)))
223     (pop rest-of-args)
224     (setq restp t)
225     (let* ((destructuring-lambda-list (car rest-of-args))
226     (sub (gensym "REST-SUBLIST")))
227     (push-sub-list-binding sub path destructuring-lambda-list
228     name error-kind error-fun)
229     (parse-defmacro-lambda-list
230     destructuring-lambda-list sub name error-kind error-fun)))
231 wlott 1.3 (t
232 wlott 1.6 (defmacro-error (symbol-name var) error-kind name))))
233 wlott 1.3 ((eq var '&optional)
234     (setf now-processing :optionals))
235     ((eq var '&key)
236     (setf now-processing :keywords)
237     (setf rest-name (gensym "KEYWORDS-"))
238 ram 1.19 (push rest-name *ignorable-vars*)
239 wlott 1.3 (setf restp t)
240 gerd 1.26 (setq key-seen t)
241 wlott 1.3 (push-let-binding rest-name path t))
242     ((eq var '&allow-other-keys)
243     (setf allow-other-keys-p t))
244     ((eq var '&aux)
245     (setf now-processing :auxs))
246 gerd 1.29 ((listp var)
247 wlott 1.3 (case now-processing
248     (:required
249     (let ((sub-list-name (gensym "SUBLIST-")))
250     (push-sub-list-binding sub-list-name `(car ,path) var
251 wlott 1.11 name error-kind error-fun)
252 wlott 1.3 (parse-defmacro-lambda-list var sub-list-name name
253 wlott 1.4 error-kind error-fun))
254 wlott 1.3 (setf path `(cdr ,path))
255     (incf minimum)
256     (incf maximum))
257     (:optionals
258     (when (> (length var) 3)
259 rtoy 1.40 (cerror (intl:gettext "Ignore extra noise.")
260     (intl:gettext "More than variable, initform, and suppliedp ~
261     in &optional binding - ~S")
262 wlott 1.3 var))
263     (push-optional-binding (car var) (cadr var) (caddr var)
264     `(not (null ,path)) `(car ,path)
265 wlott 1.4 name error-kind error-fun)
266 wlott 1.3 (setf path `(cdr ,path))
267     (incf maximum))
268     (:keywords
269     (let* ((keyword-given (consp (car var)))
270     (variable (if keyword-given
271     (cadar var)
272     (car var)))
273     (keyword (if keyword-given
274     (caar var)
275     (make-keyword variable)))
276     (supplied-p (caddr var)))
277     (push-optional-binding variable (cadr var) supplied-p
278 wlott 1.10 `(keyword-supplied-p ',keyword
279 wlott 1.3 ,rest-name)
280 wlott 1.10 `(lookup-keyword ',keyword
281     ,rest-name)
282 wlott 1.4 name error-kind error-fun)
283 wlott 1.3 (push keyword keys)))
284 wlott 1.13 (:auxs (push-let-binding (car var) (cadr var) nil))))
285     ((symbolp var)
286     (case now-processing
287     (:required
288     (incf minimum)
289     (incf maximum)
290     (push-let-binding var `(car ,path) nil)
291     (setf path `(cdr ,path)))
292     (:optionals
293     (incf maximum)
294     (push-let-binding var `(car ,path) nil `(not (null ,path)))
295     (setf path `(cdr ,path)))
296     (:keywords
297     (let ((key (make-keyword var)))
298 rtoy 1.35 ;; For deftype, the default value for a keyword is
299     ;; '*, not NIL. This hack uses ERROR-KIND to
300     ;; figure out if we're defining a new type or not.
301     (push-let-binding var
302     (if (eq error-kind 'deftype)
303     `(or (lookup-keyword ,key ,rest-name) ,*default-default*)
304     `(lookup-keyword ,key ,rest-name))
305 wlott 1.13 nil)
306     (push key keys)))
307     (:auxs
308     (push-let-binding var nil nil))))
309     (t
310 rtoy 1.40 (simple-program-error (intl:gettext "Non-symbol in lambda-list - ~S.") var)))))
311 rtoy 1.36 (push `(unless (list-length-bounded-p (the list ,(if top-level
312     `(cdr ,arg-list-name)
313     arg-list-name))
314     ,minimum
315     ,@(unless restp
316     (list maximum)))
317 gerd 1.30 ,(let ((arg (if top-level
318     `(cdr ,arg-list-name)
319     arg-list-name)))
320     (if (eq error-fun 'error)
321     `(do-arg-count-error ',error-kind ',name ,arg
322     ',lambda-list ,minimum
323     ,(unless restp maximum))
324     `(,error-fun 'defmacro-ll-arg-count-error
325 ram 1.14 :kind ',error-kind
326     ,@(when name `(:name ',name))
327     :argument ,arg
328     :lambda-list ',lambda-list
329     :minimum ,minimum
330     ,@(unless restp `(:maximum ,maximum))))))
331 gerd 1.30 *arg-tests*)
332 gerd 1.26 (when key-seen
333     (let ((problem (gensym "KEY-PROBLEM-"))
334     (info (gensym "INFO-")))
335     (push `(multiple-value-bind
336 wlott 1.6 (,problem ,info)
337 gerd 1.26 (verify-keywords ,rest-name ',keys ',allow-other-keys-p)
338     (when ,problem
339     (,error-fun
340     'defmacro-ll-broken-key-list-error
341     :kind ',error-kind
342     ,@(when name `(:name ',name))
343     :problem ,problem
344     :info ,info)))
345     *arg-tests*)))
346 wlott 1.3 (values env-arg-used minimum (if (null restp) maximum nil))))
347 ram 1.14
348     ;;; We save space in macro definitions by callig this function.
349     ;;;
350     (defun do-arg-count-error (error-kind name arg lambda-list minimum maximum)
351     (multiple-value-bind
352     (fname debug:*stack-top-hint*)
353     (kernel:find-caller-name)
354     (error 'defmacro-ll-arg-count-error
355     :kind error-kind
356     :function-name fname
357     :name name
358     :argument arg
359     :lambda-list lambda-list
360     :minimum minimum :maximum maximum)))
361 ram 1.1
362 wlott 1.11 (defun push-sub-list-binding (variable path object name error-kind error-fun)
363     (let ((var (gensym "TEMP-")))
364     (push `(,variable
365     (let ((,var ,path))
366     (if (listp ,var)
367     ,var
368     (,error-fun 'defmacro-bogus-sublist-error
369     :kind ',error-kind
370     ,@(when name `(:name ',name))
371     :object ,var
372     :lambda-list ',object))))
373     *system-lets*)))
374 ram 1.1
375 wlott 1.3 (defun push-let-binding (variable path systemp &optional condition
376 gerd 1.27 (init-form *default-default*))
377 wlott 1.3 (let ((let-form (if condition
378     `(,variable (if ,condition ,path ,init-form))
379     `(,variable ,path))))
380     (if systemp
381     (push let-form *system-lets*)
382     (push let-form *user-lets*))))
383 gerd 1.27
384     (defun append-let-binding (variable path systemp &optional condition
385     (init-form *default-default*))
386     (let ((let-form (if condition
387     `(,variable (if ,condition ,path ,init-form))
388     `(,variable ,path))))
389     (if systemp
390     (setq *system-lets* (nconc *system-lets* (list let-form)))
391     (setq *user-lets* (nconc *user-lets* (list let-form))))))
392 ram 1.1
393 wlott 1.3 (defun push-optional-binding (value-var init-form supplied-var condition path
394 wlott 1.4 name error-kind error-fun)
395 wlott 1.3 (unless supplied-var
396 rtoy 1.37 (setf supplied-var (gensym "SUPPLIEDP-")))
397 wlott 1.3 (push-let-binding supplied-var condition t)
398     (cond ((consp value-var)
399     (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
400 wlott 1.11 (push-sub-list-binding whole-thing
401     `(if ,supplied-var ,path ,init-form)
402     value-var name error-kind error-fun)
403 wlott 1.4 (parse-defmacro-lambda-list value-var whole-thing name
404     error-kind error-fun)))
405 wlott 1.3 ((symbolp value-var)
406     (push-let-binding value-var path nil supplied-var init-form))
407     (t
408 rtoy 1.40 (simple-program-error (intl:gettext "Illegal optional variable name: ~S")
409 pmai 1.22 value-var))))
410 ram 1.1
411 wlott 1.6 (defun make-keyword (symbol)
412 rtoy 1.39 "Takes a non-keyword symbol, symbol, and returns the corresponding keyword."
413 wlott 1.6 (intern (symbol-name symbol) *keyword-package*))
414 ram 1.1
415 wlott 1.6 (defun defmacro-error (problem kind name)
416 rtoy 1.40 (simple-program-error (intl:gettext "Illegal or ill-formed ~A argument in ~A~@[ ~S~].")
417 pmai 1.22 problem kind name))
418 wlott 1.4
419    
420 ram 1.1
421 wlott 1.6 ;;;; Conditions signaled at runtime by the resultant body.
422 ram 1.1
423 emarsden 1.33 (define-condition defmacro-lambda-list-bind-error (program-error)
424 wlott 1.17 ((kind :reader defmacro-lambda-list-bind-error-kind
425     :initarg :kind)
426     (name :reader defmacro-lambda-list-bind-error-name
427     :initarg :name
428     :initform nil)))
429 ram 1.1
430 wlott 1.6 (defun print-defmacro-ll-bind-error-intro (condition stream)
431     (if (null (defmacro-lambda-list-bind-error-name condition))
432     (format stream
433 rtoy 1.40 (intl:gettext "Error while parsing arguments to ~A in ~S:~%")
434 wlott 1.6 (defmacro-lambda-list-bind-error-kind condition)
435 ram 1.16 (condition-function-name condition))
436 wlott 1.6 (format stream
437 rtoy 1.40 (intl:gettext "Error while parsing arguments to ~A ~S:~%")
438 wlott 1.6 (defmacro-lambda-list-bind-error-kind condition)
439     (defmacro-lambda-list-bind-error-name condition))))
440 wlott 1.11
441     (define-condition defmacro-bogus-sublist-error
442     (defmacro-lambda-list-bind-error)
443 ram 1.16 ((object :reader defmacro-bogus-sublist-error-object :initarg :object)
444     (lambda-list :reader defmacro-bogus-sublist-error-lambda-list
445     :initarg :lambda-list))
446 wlott 1.11 (:report
447     (lambda (condition stream)
448     (print-defmacro-ll-bind-error-intro condition stream)
449     (format stream
450 rtoy 1.40 (intl:gettext "Bogus sublist:~% ~S~%to satisfy lambda-list:~% ~:S~%")
451 wlott 1.11 (defmacro-bogus-sublist-error-object condition)
452     (defmacro-bogus-sublist-error-lambda-list condition)))))
453 ram 1.1
454 wlott 1.6 (define-condition defmacro-ll-arg-count-error (defmacro-lambda-list-bind-error)
455 ram 1.16 ((argument :reader defmacro-ll-arg-count-error-argument :initarg :argument)
456     (lambda-list :reader defmacro-ll-arg-count-error-lambda-list
457     :initarg :lambda-list)
458     (minimum :reader defmacro-ll-arg-count-error-minimum :initarg :minimum)
459     (maximum :reader defmacro-ll-arg-count-error-maximum :initarg :maximum))
460 wlott 1.6 (:report
461     (lambda (condition stream)
462     (print-defmacro-ll-bind-error-intro condition stream)
463     (format stream
464 rtoy 1.40 (intl:gettext "Invalid number of elements in:~% ~:S~%~
465     to satisfy lambda-list:~% ~:S~%")
466 wlott 1.6 (defmacro-ll-arg-count-error-argument condition)
467     (defmacro-ll-arg-count-error-lambda-list condition))
468     (cond ((null (defmacro-ll-arg-count-error-maximum condition))
469 rtoy 1.40 (format stream (intl:gettext "Expected at least ~D")
470 wlott 1.6 (defmacro-ll-arg-count-error-minimum condition)))
471     ((= (defmacro-ll-arg-count-error-minimum condition)
472     (defmacro-ll-arg-count-error-maximum condition))
473 rtoy 1.40 (format stream (intl:gettext "Expected exactly ~D")
474 wlott 1.6 (defmacro-ll-arg-count-error-minimum condition)))
475     (t
476 rtoy 1.40 (format stream (intl:gettext "Expected between ~D and ~D")
477 wlott 1.6 (defmacro-ll-arg-count-error-minimum condition)
478     (defmacro-ll-arg-count-error-maximum condition))))
479 rtoy 1.40 (format stream (intl:gettext ", but got ~D.")
480 wlott 1.6 (length (defmacro-ll-arg-count-error-argument condition))))))
481 ram 1.1
482    
483 wlott 1.6 (define-condition defmacro-ll-broken-key-list-error
484     (defmacro-lambda-list-bind-error)
485 ram 1.16 ((problem :reader defmacro-ll-broken-key-list-error-problem
486     :initarg :problem)
487     (info :reader defmacro-ll-broken-key-list-error-info :initarg :info))
488 wlott 1.6 (:report (lambda (condition stream)
489     (print-defmacro-ll-bind-error-intro condition stream)
490     (format stream
491     (ecase
492     (defmacro-ll-broken-key-list-error-problem condition)
493     (:dotted-list
494     "Keyword/value list is dotted: ~S")
495     (:odd-length
496     "Odd number of elements in keyword/value list: ~S")
497     (:duplicate
498     "Duplicate keyword: ~S")
499     (:unknown-keyword
500     "~{Unknown keyword: ~S; expected one of ~{~S~^, ~}~}"))
501     (defmacro-ll-broken-key-list-error-info condition)))))

  ViewVC Help
Powered by ViewVC 1.1.5