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

Contents of /src/code/defmacro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (show 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 ;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/defmacro.lisp,v 1.40 2010/04/20 17:57:44 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Written by Blaine Burks.
13 ;;;
14 (in-package "LISP")
15
16 (intl:textdomain "cmucl")
17
18
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 ;;;
24 (defvar *arg-tests* ()
25 "A list of tests that do argument counting at expansion time.")
26
27 (defvar *system-lets* ()
28 "Let bindings that are done to make lambda-list parsing possible.")
29
30 (defvar *user-lets* ()
31 "Let bindings that the user has explicitly supplied.")
32
33 (defvar *default-default* nil
34 "Unsupplied optional and keyword arguments get this value defaultly.")
35
36 ;; Temps that we introduce and might not reference.
37 (defvar *ignorable-vars*)
38
39
40
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 ;;;
47 (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 (error-fun 'error))
53 "Returns as multiple-values a parsed body, any local-declarations that
54 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 (*system-lets* ())
61 (*ignorable-vars* ()))
62 (multiple-value-bind
63 (env-arg-used minimum maximum)
64 (parse-defmacro-lambda-list lambda-list arg-list-name name
65 error-kind error-fun (not annonymousp)
66 nil env-arg-name)
67 (values
68 `(let* ,(nreverse *system-lets*)
69 ,@(when *ignorable-vars*
70 `((declare (ignorable ,@*ignorable-vars*))))
71 ,@*arg-tests*
72 (let* ,(nreverse *user-lets*)
73 ,@declarations
74 ,@body))
75 `(,@(when (and env-arg-name (not env-arg-used))
76 `((declare (ignore ,env-arg-name)))))
77 documentation
78 minimum
79 maximum)))))
80
81 (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
89 #+nil
90 (declaim (inline dotted-list-length))
91 ;;; FIXME: Remove this later! This was left here to make
92 ;;; bootstrapping list-length-bounded-p easier.
93 (defun dotted-list-length (list)
94 ;; 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 (loop for tail on list until (atom tail) count t))
98
99
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 (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 (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name))
121 (lambda-list (restify-dotted-lambda-list lambda-list))
122 (now-processing :required)
123 (maximum 0)
124 (minimum 0)
125 (keys ())
126 (key-seen nil)
127 rest-name restp allow-other-keys-p env-arg-used)
128 (when (and (member '&whole lambda-list)
129 (not (eq (car lambda-list) '&whole)))
130 (simple-program-error (intl:gettext "&Whole must appear first in ~S lambda-list.")
131 error-kind))
132 (do ((rest-of-args lambda-list (cdr rest-of-args)))
133 ((null rest-of-args))
134 (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 ;; 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 (push-let-binding (car rest-of-args) arg-list-name nil))
156 ((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 (t
166 (defmacro-error "&WHOLE" error-kind name))))
167 ((eq var '&environment)
168 (cond (env-illegal
169 (simple-program-error (intl:gettext "&environment not valid with ~S.")
170 error-kind))
171 ((not top-level)
172 (simple-program-error
173 (intl:gettext "&environment only valid at top level of lambda-list."))))
174 (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
175 (setf rest-of-args (cdr rest-of-args))
176 (append-let-binding (car rest-of-args) env-arg-name nil)
177 (setf env-arg-used t))
178 (t
179 (defmacro-error "&ENVIRONMENT" error-kind name))))
180 ;;
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 (simple-program-error (intl:gettext "Invalid ~a") '&parse-body))
191 (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 (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 (setf rest-of-args (cdr rest-of-args))
220 (setf restp t)
221 (push-let-binding (car rest-of-args) path nil))
222 ((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 (t
232 (defmacro-error (symbol-name var) error-kind name))))
233 ((eq var '&optional)
234 (setf now-processing :optionals))
235 ((eq var '&key)
236 (setf now-processing :keywords)
237 (setf rest-name (gensym "KEYWORDS-"))
238 (push rest-name *ignorable-vars*)
239 (setf restp t)
240 (setq key-seen t)
241 (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 ((listp var)
247 (case now-processing
248 (:required
249 (let ((sub-list-name (gensym "SUBLIST-")))
250 (push-sub-list-binding sub-list-name `(car ,path) var
251 name error-kind error-fun)
252 (parse-defmacro-lambda-list var sub-list-name name
253 error-kind error-fun))
254 (setf path `(cdr ,path))
255 (incf minimum)
256 (incf maximum))
257 (:optionals
258 (when (> (length var) 3)
259 (cerror (intl:gettext "Ignore extra noise.")
260 (intl:gettext "More than variable, initform, and suppliedp ~
261 in &optional binding - ~S")
262 var))
263 (push-optional-binding (car var) (cadr var) (caddr var)
264 `(not (null ,path)) `(car ,path)
265 name error-kind error-fun)
266 (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 `(keyword-supplied-p ',keyword
279 ,rest-name)
280 `(lookup-keyword ',keyword
281 ,rest-name)
282 name error-kind error-fun)
283 (push keyword keys)))
284 (: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 ;; 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 nil)
306 (push key keys)))
307 (:auxs
308 (push-let-binding var nil nil))))
309 (t
310 (simple-program-error (intl:gettext "Non-symbol in lambda-list - ~S.") var)))))
311 (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 ,(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 :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 *arg-tests*)
332 (when key-seen
333 (let ((problem (gensym "KEY-PROBLEM-"))
334 (info (gensym "INFO-")))
335 (push `(multiple-value-bind
336 (,problem ,info)
337 (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 (values env-arg-used minimum (if (null restp) maximum nil))))
347
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
362 (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
375 (defun push-let-binding (variable path systemp &optional condition
376 (init-form *default-default*))
377 (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
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
393 (defun push-optional-binding (value-var init-form supplied-var condition path
394 name error-kind error-fun)
395 (unless supplied-var
396 (setf supplied-var (gensym "SUPPLIEDP-")))
397 (push-let-binding supplied-var condition t)
398 (cond ((consp value-var)
399 (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
400 (push-sub-list-binding whole-thing
401 `(if ,supplied-var ,path ,init-form)
402 value-var name error-kind error-fun)
403 (parse-defmacro-lambda-list value-var whole-thing name
404 error-kind error-fun)))
405 ((symbolp value-var)
406 (push-let-binding value-var path nil supplied-var init-form))
407 (t
408 (simple-program-error (intl:gettext "Illegal optional variable name: ~S")
409 value-var))))
410
411 (defun make-keyword (symbol)
412 "Takes a non-keyword symbol, symbol, and returns the corresponding keyword."
413 (intern (symbol-name symbol) *keyword-package*))
414
415 (defun defmacro-error (problem kind name)
416 (simple-program-error (intl:gettext "Illegal or ill-formed ~A argument in ~A~@[ ~S~].")
417 problem kind name))
418
419
420
421 ;;;; Conditions signaled at runtime by the resultant body.
422
423 (define-condition defmacro-lambda-list-bind-error (program-error)
424 ((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
430 (defun print-defmacro-ll-bind-error-intro (condition stream)
431 (if (null (defmacro-lambda-list-bind-error-name condition))
432 (format stream
433 (intl:gettext "Error while parsing arguments to ~A in ~S:~%")
434 (defmacro-lambda-list-bind-error-kind condition)
435 (condition-function-name condition))
436 (format stream
437 (intl:gettext "Error while parsing arguments to ~A ~S:~%")
438 (defmacro-lambda-list-bind-error-kind condition)
439 (defmacro-lambda-list-bind-error-name condition))))
440
441 (define-condition defmacro-bogus-sublist-error
442 (defmacro-lambda-list-bind-error)
443 ((object :reader defmacro-bogus-sublist-error-object :initarg :object)
444 (lambda-list :reader defmacro-bogus-sublist-error-lambda-list
445 :initarg :lambda-list))
446 (:report
447 (lambda (condition stream)
448 (print-defmacro-ll-bind-error-intro condition stream)
449 (format stream
450 (intl:gettext "Bogus sublist:~% ~S~%to satisfy lambda-list:~% ~:S~%")
451 (defmacro-bogus-sublist-error-object condition)
452 (defmacro-bogus-sublist-error-lambda-list condition)))))
453
454 (define-condition defmacro-ll-arg-count-error (defmacro-lambda-list-bind-error)
455 ((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 (:report
461 (lambda (condition stream)
462 (print-defmacro-ll-bind-error-intro condition stream)
463 (format stream
464 (intl:gettext "Invalid number of elements in:~% ~:S~%~
465 to satisfy lambda-list:~% ~:S~%")
466 (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 (format stream (intl:gettext "Expected at least ~D")
470 (defmacro-ll-arg-count-error-minimum condition)))
471 ((= (defmacro-ll-arg-count-error-minimum condition)
472 (defmacro-ll-arg-count-error-maximum condition))
473 (format stream (intl:gettext "Expected exactly ~D")
474 (defmacro-ll-arg-count-error-minimum condition)))
475 (t
476 (format stream (intl:gettext "Expected between ~D and ~D")
477 (defmacro-ll-arg-count-error-minimum condition)
478 (defmacro-ll-arg-count-error-maximum condition))))
479 (format stream (intl:gettext ", but got ~D.")
480 (length (defmacro-ll-arg-count-error-argument condition))))))
481
482
483 (define-condition defmacro-ll-broken-key-list-error
484 (defmacro-lambda-list-bind-error)
485 ((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 (: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