/[cmucl]/src/bootfiles/18e/boot5.lisp
ViewVC logotype

Contents of /src/bootfiles/18e/boot5.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Sun Apr 20 22:21:00 2003 UTC (11 years ago) by toy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.2: +2 -2 lines
Rename &parse-body to ext::&parse-body so pmai's scripts work.
(exports.lisp is loaded too late for this to get the right value of
&parse-body.)
1 ;;;
2 ;;; Bootfile for changes in macro lambda-list processing.
3 ;;; Destructuring in &REST, &BODY, and &WHOLE. Addition
4 ;;; of EXT:&PARSE-BODY.
5 ;;;
6
7 (in-package :lisp)
8
9 (defun parse-defmacro-lambda-list
10 (lambda-list arg-list-name name error-kind error-fun
11 &optional top-level env-illegal env-arg-name)
12 (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name))
13 (now-processing :required)
14 (maximum 0)
15 (minimum 0)
16 (keys ())
17 rest-name restp allow-other-keys-p env-arg-used)
18 ;; This really strange way to test for '&whole is neccessary because member
19 ;; does not have to work on dotted lists, and dotted lists are legal
20 ;; in lambda-lists.
21 (when (and (do ((list lambda-list (cdr list)))
22 ((atom list) nil)
23 (when (eq (car list) '&whole) (return t)))
24 (not (eq (car lambda-list) '&whole)))
25 (simple-program-error "&Whole must appear first in ~S lambda-list."
26 error-kind))
27 (do ((rest-of-args lambda-list (cdr rest-of-args)))
28 ((atom rest-of-args)
29 (cond ((null rest-of-args) nil)
30 ;; Varlist is dotted, treat as &rest arg and exit.
31 (t (push-let-binding rest-of-args path nil)
32 (setf restp :dotted))))
33 (let ((var (car rest-of-args)))
34 (cond ((eq var '&whole)
35 (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
36 (setf rest-of-args (cdr rest-of-args))
37 ;; For compiler macros, we have to do something
38 ;; special in case the form has a car eq to
39 ;; funcall, as specified in the CLHS. In this
40 ;; case, we skip over the funcall and pretend
41 ;; that the rest of the form is the actual form.
42 ;;
43 ;; This is a gross hack because we look at
44 ;; error-kind to figure out if we're defining a
45 ;; compiler macro or not.
46 (when (eq error-kind 'define-compiler-macro)
47 (push-let-binding arg-list-name arg-list-name
48 t
49 `(progn
50 (not (and (listp ,arg-list-name)
51 (eq 'funcall (car ,arg-list-name)))))
52 `(progn
53 (setf ,arg-list-name (cdr ,arg-list-name)))))
54 (push-let-binding (car rest-of-args) arg-list-name nil))
55 ((and (cdr rest-of-args) (consp (cadr rest-of-args)))
56 (pop rest-of-args)
57 (let* ((destructuring-lambda-list (car rest-of-args))
58 (sub (gensym "WHOLE-SUBLIST")))
59 (push-sub-list-binding
60 sub arg-list-name destructuring-lambda-list
61 name error-kind error-fun)
62 (parse-defmacro-lambda-list
63 destructuring-lambda-list sub name error-kind error-fun)))
64 (t
65 (defmacro-error "&WHOLE" error-kind name))))
66 ((eq var '&environment)
67 (cond (env-illegal
68 (simple-program-error "&environment not valid with ~S."
69 error-kind))
70 ((not top-level)
71 (simple-program-error
72 "&environment only valid at top level of lambda-list.")))
73 (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
74 (setf rest-of-args (cdr rest-of-args))
75 (push-let-binding (car rest-of-args) env-arg-name nil)
76 (setf env-arg-used t))
77 (t
78 (defmacro-error "&ENVIRONMENT" error-kind name))))
79 ;;
80 ;; This branch implements an extension to Common Lisp
81 ;; that was formerly implemented for &body. In place of
82 ;; a symbol following &body, there could be a list of up
83 ;; to three elements which will be bound to the body,
84 ;; declarations, and doc-string of the body.
85 ((eq var 'ext::&parse-body)
86 (unless (and (cdr rest-of-args)
87 (consp (cadr rest-of-args))
88 (symbolp (caadr rest-of-args)))
89 (simple-program-error "Invalid ~a" 'ext::&parse-body))
90 (setf rest-of-args (cdr rest-of-args))
91 (setf restp t)
92 (let ((body-name (caar rest-of-args))
93 (declarations-name (cadar rest-of-args))
94 (doc-string-name (caddar rest-of-args))
95 (parse-body-values (gensym)))
96 (push-let-binding
97 parse-body-values
98 `(multiple-value-list
99 (parse-body ,path ,env-arg-name
100 ,(not (null doc-string-name))))
101 t)
102 (setf env-arg-used t)
103 (when body-name
104 (push-let-binding body-name
105 `(car ,parse-body-values) nil))
106 (when declarations-name
107 (push-let-binding declarations-name
108 `(cadr ,parse-body-values) nil))
109 (when doc-string-name
110 (push-let-binding doc-string-name
111 `(caddr ,parse-body-values) nil))))
112 ;;
113 ((member var '(&rest &body))
114 (cond ((and (cddr rest-of-args)
115 (not (member (caddr rest-of-args) lambda-list-keywords)))
116 (defmacro-error (symbol-name var) error-kind name))
117 ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
118 (setf rest-of-args (cdr rest-of-args))
119 (setf restp t)
120 (push-let-binding (car rest-of-args) path nil))
121 ((and (cdr rest-of-args) (consp (cadr rest-of-args)))
122 (pop rest-of-args)
123 (setq restp t)
124 (let* ((destructuring-lambda-list (car rest-of-args))
125 (sub (gensym "REST-SUBLIST")))
126 (push-sub-list-binding sub path destructuring-lambda-list
127 name error-kind error-fun)
128 (parse-defmacro-lambda-list
129 destructuring-lambda-list sub name error-kind error-fun)))
130 (t
131 (defmacro-error (symbol-name var) error-kind name))))
132 ((eq var '&optional)
133 (setf now-processing :optionals))
134 ((eq var '&key)
135 (setf now-processing :keywords)
136 (setf rest-name (gensym "KEYWORDS-"))
137 (push rest-name *ignorable-vars*)
138 (setf restp t)
139 (push-let-binding rest-name path t))
140 ((eq var '&allow-other-keys)
141 (setf allow-other-keys-p t))
142 ((eq var '&aux)
143 (setf now-processing :auxs))
144 ((listp var)
145 (case now-processing
146 (:required
147 (let ((sub-list-name (gensym "SUBLIST-")))
148 (push-sub-list-binding sub-list-name `(car ,path) var
149 name error-kind error-fun)
150 (parse-defmacro-lambda-list var sub-list-name name
151 error-kind error-fun))
152 (setf path `(cdr ,path))
153 (incf minimum)
154 (incf maximum))
155 (:optionals
156 (when (> (length var) 3)
157 (cerror "Ignore extra noise."
158 "More than variable, initform, and suppliedp ~
159 in &optional binding - ~S"
160 var))
161 (push-optional-binding (car var) (cadr var) (caddr var)
162 `(not (null ,path)) `(car ,path)
163 name error-kind error-fun)
164 (setf path `(cdr ,path))
165 (incf maximum))
166 (:keywords
167 (let* ((keyword-given (consp (car var)))
168 (variable (if keyword-given
169 (cadar var)
170 (car var)))
171 (keyword (if keyword-given
172 (caar var)
173 (make-keyword variable)))
174 (supplied-p (caddr var)))
175 (push-optional-binding variable (cadr var) supplied-p
176 `(keyword-supplied-p ',keyword
177 ,rest-name)
178 `(lookup-keyword ',keyword
179 ,rest-name)
180 name error-kind error-fun)
181 (push keyword keys)))
182 (:auxs (push-let-binding (car var) (cadr var) nil))))
183 ((symbolp var)
184 (case now-processing
185 (:required
186 (incf minimum)
187 (incf maximum)
188 (push-let-binding var `(car ,path) nil)
189 (setf path `(cdr ,path)))
190 (:optionals
191 (incf maximum)
192 (push-let-binding var `(car ,path) nil `(not (null ,path)))
193 (setf path `(cdr ,path)))
194 (:keywords
195 (let ((key (make-keyword var)))
196 (push-let-binding var `(lookup-keyword ,key ,rest-name)
197 nil)
198 (push key keys)))
199 (:auxs
200 (push-let-binding var nil nil))))
201 (t
202 (simple-program-error "Non-symbol in lambda-list - ~S." var)))))
203 ;; Generate code to check the number of arguments, unless dotted
204 ;; in which case length will not work.
205 (unless (eq restp :dotted)
206 (push `(unless (<= ,minimum
207 (length (the list ,(if top-level
208 `(cdr ,arg-list-name)
209 arg-list-name)))
210 ,@(unless restp
211 (list maximum)))
212 ,(let ((arg (if top-level
213 `(cdr ,arg-list-name)
214 arg-list-name)))
215 (if (eq error-fun 'error)
216 `(do-arg-count-error ',error-kind ',name ,arg
217 ',lambda-list ,minimum
218 ,(unless restp maximum))
219 `(,error-fun 'defmacro-ll-arg-count-error
220 :kind ',error-kind
221 ,@(when name `(:name ',name))
222 :argument ,arg
223 :lambda-list ',lambda-list
224 :minimum ,minimum
225 ,@(unless restp `(:maximum ,maximum))))))
226 *arg-tests*))
227 (if keys
228 (let ((problem (gensym "KEY-PROBLEM-"))
229 (info (gensym "INFO-")))
230 (push `(multiple-value-bind
231 (,problem ,info)
232 (verify-keywords ,rest-name ',keys ',allow-other-keys-p)
233 (when ,problem
234 (,error-fun
235 'defmacro-ll-broken-key-list-error
236 :kind ',error-kind
237 ,@(when name `(:name ',name))
238 :problem ,problem
239 :info ,info)))
240 *arg-tests*)))
241 (values env-arg-used minimum (if (null restp) maximum nil))))
242
243 ;;; end of file

  ViewVC Help
Powered by ViewVC 1.1.5