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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Fri Jun 20 11:06:15 2003 UTC (10 years, 10 months ago) by gerd
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, 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: +366 -11 lines
	* src/bootfiles/18e/boot13.lisp (relative-package-name-to-package)
	(read-token): Add.
	(toplevel): Set the readtable entry for #\: to the new read-token.
1 ;;;
2 ;;; Boot file for removing the "" nickname of the KEYWORD package,
3 ;;; removing the USER nickname from CL-USER, and removing the
4 ;;; LISP nickname from COMMON-LISP, the latter by introducing
5 ;;; a new COMMON-LISP package which LISP uses.
6 ;;;
7 ;;; To bootstrap, copy this file to target:bootstrap.lisp
8 ;;; using Pierre Mai's build scripts, and do a full build.
9 ;;;
10
11 (in-package :lisp)
12
13 #+relative-package-names
14 (defun relative-package-name-to-package (name)
15 (declare (simple-string name)
16 (optimize (speed 3)))
17 (flet ((relative-to (package name)
18 (declare (type package package)
19 (simple-string name))
20 (if (string= "" name)
21 package
22 (let ((parent-name (package-%name package)))
23 (unless parent-name
24 (error "Can't do anything to a deleted package: ~S"
25 package))
26 (package-name-to-package
27 (concatenate 'simple-string parent-name "." name)))))
28 (find-non-dot (name)
29 (do* ((len (length name))
30 (i 0 (1+ i)))
31 ((= i len) nil)
32 (declare (type index len i))
33 (when (char/= #\. (schar name i)) (return i)))))
34 (when (and (plusp (length name))
35 (char= #\. (schar name 0)))
36 (let* ((last-dot-position (or (find-non-dot name) (length name)))
37 (n-dots last-dot-position)
38 (name (subseq name last-dot-position)))
39 (cond ((= 1 n-dots)
40 ;; relative to current package
41 (relative-to *package* name))
42 (t
43 ;; relative to our (- n-dots 1)'th parent
44 (let ((package *package*)
45 (tmp nil))
46 (dotimes (i (1- n-dots))
47 (declare (fixnum i))
48 (setq tmp (package-parent package))
49 (unless tmp
50 (error 'simple-package-error
51 :name (string package)
52 :format-control "The parent of ~a does not exist."
53 :format-arguments (list package)))
54 (setq package tmp))
55 (relative-to package name))))))))
56
57 (defun read-token (stream firstchar)
58 "This function is just an fsm that recognizes numbers and symbols."
59 ;;check explicitly whether firstchar has entry for non-terminating
60 ;;in character-attribute-table and read-dot-number-symbol in CMT.
61 ;;Report an error if these are violated (if we called this, we want
62 ;;something that is a legitimate token!).
63 ;;read in the longest possible string satisfying the bnf for
64 ;;"unqualified-token". Leave the result in the READ-BUFFER.
65 ;;Return next char after token (last char read).
66 (when *read-suppress*
67 (internal-read-extended-token stream firstchar nil)
68 (return-from read-token nil))
69 (let ((attribute-table (character-attribute-table *readtable*))
70 (package nil)
71 (colons 0)
72 (possibly-rational t)
73 (possibly-float t)
74 (escapes ()))
75 (reset-read-buffer)
76 (prog ((char firstchar))
77 (case (char-class3 char attribute-table)
78 (#.constituent-sign (go SIGN))
79 (#.constituent-digit (go LEFTDIGIT))
80 (#.constituent-dot (go FRONTDOT))
81 (#.escape (go ESCAPE))
82 (#.package-delimiter (go COLON))
83 (#.multiple-escape (go MULT-ESCAPE))
84 ;;can't have eof, whitespace, or terminating macro as first char!
85 (t (go SYMBOL)))
86 SIGN
87 ;;saw "sign"
88 (ouch-read-buffer char)
89 (setq char (read-char stream nil nil))
90 (unless char (go RETURN-SYMBOL))
91 (setq possibly-rational t
92 possibly-float t)
93 (case (char-class3 char attribute-table)
94 (#.constituent-digit (go LEFTDIGIT))
95 (#.constituent-dot (go SIGNDOT))
96 (#.escape (go ESCAPE))
97 (#.package-delimiter (go COLON))
98 (#.multiple-escape (go MULT-ESCAPE))
99 (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
100 (t (go SYMBOL)))
101 LEFTDIGIT
102 ;;saw "[sign] {digit}+"
103 (ouch-read-buffer char)
104 (setq char (read-char stream nil nil))
105 (unless char (return (make-integer)))
106 (case (char-class3 char attribute-table)
107 (#.constituent-digit (go LEFTDIGIT))
108 (#.constituent-dot (if possibly-float
109 (go MIDDLEDOT)
110 (go SYMBOL)))
111 (#.constituent-expt (go EXPONENT))
112 (#.constituent-slash (if possibly-rational
113 (go RATIO)
114 (go SYMBOL)))
115 (#.delimiter (unread-char char stream) (return (make-integer)))
116 (#.escape (go ESCAPE))
117 (#.multiple-escape (go MULT-ESCAPE))
118 (#.package-delimiter (go COLON))
119 (t (go SYMBOL)))
120 MIDDLEDOT
121 ;;saw "[sign] {digit}+ dot"
122 (ouch-read-buffer char)
123 (setq char (read-char stream nil nil))
124 (unless char (return (let ((*read-base* 10))
125 (make-integer))))
126 (case (char-class char attribute-table)
127 (#.constituent-digit (go RIGHTDIGIT))
128 (#.constituent-expt (go EXPONENT))
129 (#.delimiter
130 (unread-char char stream)
131 (return (let ((*read-base* 10))
132 (make-integer))))
133 (#.escape (go ESCAPE))
134 (#.multiple-escape (go MULT-ESCAPE))
135 (#.package-delimiter (go COLON))
136 (t (go SYMBOL)))
137 RIGHTDIGIT
138 ;;saw "[sign] {digit}* dot {digit}+"
139 (ouch-read-buffer char)
140 (setq char (read-char stream nil nil))
141 (unless char (return (make-float)))
142 (case (char-class char attribute-table)
143 (#.constituent-digit (go RIGHTDIGIT))
144 (#.constituent-expt (go EXPONENT))
145 (#.delimiter (unread-char char stream) (return (make-float)))
146 (#.escape (go ESCAPE))
147 (#.multiple-escape (go MULT-ESCAPE))
148 (#.package-delimiter (go COLON))
149 (t (go SYMBOL)))
150 SIGNDOT
151 ;;saw "[sign] dot"
152 (ouch-read-buffer char)
153 (setq char (read-char stream nil nil))
154 (unless char (go RETURN-SYMBOL))
155 (case (char-class char attribute-table)
156 (#.constituent-digit (go RIGHTDIGIT))
157 (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
158 (#.escape (go ESCAPE))
159 (#.multiple-escape (go MULT-ESCAPE))
160 (t (go SYMBOL)))
161 FRONTDOT
162 ;;saw "dot"
163 (ouch-read-buffer char)
164 (setq char (read-char stream nil nil))
165 (unless char (%reader-error stream "Dot context error."))
166 (case (char-class char attribute-table)
167 (#.constituent-digit (go RIGHTDIGIT))
168 (#.constituent-dot (go DOTS))
169 (#.delimiter (%reader-error stream "Dot context error."))
170 (#.escape (go ESCAPE))
171 (#.multiple-escape (go MULT-ESCAPE))
172 (#.package-delimiter (go COLON))
173 (t (go SYMBOL)))
174 EXPONENT
175 (ouch-read-buffer char)
176 (setq char (read-char stream nil nil))
177 (unless char (go RETURN-SYMBOL))
178 (case (char-class char attribute-table)
179 (#.constituent-sign (go EXPTSIGN))
180 (#.constituent-digit (go EXPTDIGIT))
181 (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
182 (#.escape (go ESCAPE))
183 (#.multiple-escape (go MULT-ESCAPE))
184 (#.package-delimiter (go COLON))
185 (t (go SYMBOL)))
186 EXPTSIGN
187 ;;we got to EXPONENT, and saw a sign character.
188 (ouch-read-buffer char)
189 (setq char (read-char stream nil nil))
190 (unless char (go RETURN-SYMBOL))
191 (case (char-class char attribute-table)
192 (#.constituent-digit (go EXPTDIGIT))
193 (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
194 (#.escape (go ESCAPE))
195 (#.multiple-escape (go MULT-ESCAPE))
196 (#.package-delimiter (go COLON))
197 (t (go SYMBOL)))
198 EXPTDIGIT
199 ;;got to EXPONENT, saw "[sign] {digit}+"
200 (ouch-read-buffer char)
201 (setq char (read-char stream nil nil))
202 (unless char (return (make-float)))
203 (case (char-class char attribute-table)
204 (#.constituent-digit (go EXPTDIGIT))
205 (#.delimiter (unread-char char stream) (return (make-float)))
206 (#.escape (go ESCAPE))
207 (#.multiple-escape (go MULT-ESCAPE))
208 (#.package-delimiter (go COLON))
209 (t (go SYMBOL)))
210 RATIO
211 ;;saw "[sign] {digit}+ slash"
212 (ouch-read-buffer char)
213 (setq char (read-char stream nil nil))
214 (unless char (go RETURN-SYMBOL))
215 (case (char-class2 char attribute-table)
216 (#.constituent-digit (go RATIODIGIT))
217 (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
218 (#.escape (go ESCAPE))
219 (#.multiple-escape (go MULT-ESCAPE))
220 (#.package-delimiter (go COLON))
221 (t (go SYMBOL)))
222 RATIODIGIT
223 ;;saw "[sign] {digit}+ slash {digit}+"
224 (ouch-read-buffer char)
225 (setq char (read-char stream nil nil))
226 (unless char (return (make-ratio)))
227 (case (char-class2 char attribute-table)
228 (#.constituent-digit (go RATIODIGIT))
229 (#.delimiter (unread-char char stream) (return (make-ratio)))
230 (#.escape (go ESCAPE))
231 (#.multiple-escape (go MULT-ESCAPE))
232 (#.package-delimiter (go COLON))
233 (t (go SYMBOL)))
234 DOTS
235 ;;saw "dot {dot}+"
236 (ouch-read-buffer char)
237 (setq char (read-char stream nil nil))
238 (unless char (%reader-error stream "Too many dots."))
239 (case (char-class char attribute-table)
240 (#.constituent-dot (go DOTS))
241 (#.delimiter
242 (unread-char char stream)
243 (%reader-error stream "Too many dots."))
244 (#.escape (go ESCAPE))
245 (#.multiple-escape (go MULT-ESCAPE))
246 (#.package-delimiter (go COLON))
247 (t (go SYMBOL)))
248 SYMBOL
249 ;;not a dot, dots, or number.
250 (let ((stream (in-synonym-of stream)))
251 (if (lisp-stream-p stream)
252 (prepare-for-fast-read-char stream
253 (prog ()
254 SYMBOL-LOOP
255 (ouch-read-buffer char)
256 (setq char (fast-read-char nil nil))
257 (unless char (go RETURN-SYMBOL))
258 (case (char-class char attribute-table)
259 (#.escape (done-with-fast-read-char)
260 (go ESCAPE))
261 (#.delimiter (done-with-fast-read-char)
262 (unread-char char stream)
263 (go RETURN-SYMBOL))
264 (#.multiple-escape (done-with-fast-read-char)
265 (go MULT-ESCAPE))
266 (#.package-delimiter (done-with-fast-read-char)
267 (go COLON))
268 (t (go SYMBOL-LOOP)))))
269 ;; Fundamental-stream.
270 (prog ()
271 SYMBOL-LOOP
272 (ouch-read-buffer char)
273 (setq char (stream-read-char stream))
274 (when (eq char :eof) (go RETURN-SYMBOL))
275 (case (char-class char attribute-table)
276 (#.escape (go ESCAPE))
277 (#.delimiter (stream-unread-char stream char)
278 (go RETURN-SYMBOL))
279 (#.multiple-escape (go MULT-ESCAPE))
280 (#.package-delimiter (go COLON))
281 (t (go SYMBOL-LOOP))))))
282 ESCAPE
283 ;;saw an escape.
284 ;;don't put the escape in the read-buffer.
285 ;;read-next char, put in buffer (no case conversion).
286 (let ((nextchar (read-char stream nil nil)))
287 (unless nextchar
288 (reader-eof-error stream "after escape character"))
289 (push ouch-ptr escapes)
290 (ouch-read-buffer nextchar))
291 (setq char (read-char stream nil nil))
292 (unless char (go RETURN-SYMBOL))
293 (case (char-class char attribute-table)
294 (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
295 (#.escape (go ESCAPE))
296 (#.multiple-escape (go MULT-ESCAPE))
297 (#.package-delimiter (go COLON))
298 (t (go SYMBOL)))
299 MULT-ESCAPE
300 (do ((char (read-char stream t) (read-char stream t)))
301 ((multiple-escape-p char))
302 (if (escapep char) (setq char (read-char stream t)))
303 (push ouch-ptr escapes)
304 (ouch-read-buffer char))
305 (setq char (read-char stream nil nil))
306 (unless char (go RETURN-SYMBOL))
307 (case (char-class char attribute-table)
308 (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
309 (#.escape (go ESCAPE))
310 (#.multiple-escape (go MULT-ESCAPE))
311 (#.package-delimiter (go COLON))
312 (t (go SYMBOL)))
313 COLON
314 (casify-read-buffer escapes)
315 (unless (zerop colons)
316 (%reader-error stream "Too many colons in ~S"
317 (read-buffer-to-string)))
318 (setq colons 1)
319 (setq package
320 (if (eql (char-class firstchar attribute-table)
321 #.package-delimiter)
322 *keyword-package*
323 (read-buffer-to-string)))
324 (reset-read-buffer)
325 (setq escapes ())
326 (setq char (read-char stream nil nil))
327 (unless char (reader-eof-error stream "after reading a colon"))
328 (case (char-class char attribute-table)
329 (#.delimiter
330 (unread-char char stream)
331 (%reader-error stream "Illegal terminating character after a colon, ~S."
332 char))
333 (#.escape (go ESCAPE))
334 (#.multiple-escape (go MULT-ESCAPE))
335 (#.package-delimiter (go INTERN))
336 (t (go SYMBOL)))
337 INTERN
338 (setq colons 2)
339 (setq char (read-char stream nil nil))
340 (unless char
341 (reader-eof-error stream "after reading a colon"))
342 (case (char-class char attribute-table)
343 (#.delimiter
344 (unread-char char stream)
345 (%reader-error stream "Illegal terminating character after a colon, ~S"
346 char))
347 (#.escape (go ESCAPE))
348 (#.multiple-escape (go MULT-ESCAPE))
349 (#.package-delimiter
350 (%reader-error stream "To many colons after ~S:" package))
351 (t (go SYMBOL)))
352 RETURN-SYMBOL
353 (casify-read-buffer escapes)
354 (let ((found (if package
355 (find-package package)
356 *package*)))
357 (unless found
358 (error 'reader-package-error :stream stream
359 :format-arguments (list package)
360 :format-control "Package ~S not found."))
361
362 (if (or (zerop colons) (= colons 2) (eq found *keyword-package*))
363 (return (intern* read-buffer ouch-ptr found))
364 (multiple-value-bind (symbol test)
365 (find-symbol* read-buffer ouch-ptr found)
366 (when (eq test :external) (return symbol))
367 (let ((name (read-buffer-to-string)))
368 (with-simple-restart (continue "Use symbol anyway.")
369 (error 'reader-package-error :stream stream
370 :format-arguments (list name (package-name found))
371 :format-control
372 (if test
373 "The symbol ~S is not external in the ~A package."
374 "Symbol ~S not found in the ~A package.")))
375 (return (intern name found)))))))))
376
377 (set-cmt-entry #\: #'read-token)
378
379 (rename-package "KEYWORD" "KEYWORD" nil)
380
381 (cl:rename-package "COMMON-LISP-USER" "COMMON-LISP-USER" '("CL-USER"))
382 (unuse-package "COMMON-LISP" "COMMON-LISP-USER")
383 (use-package "LISP" "COMMON-LISP-USER")
384
385 (rename-package "COMMON-LISP" "COMMON-LISP" nil)
386 (rename-package "COMMON-LISP" "LISP" nil)
387 (make-package "COMMON-LISP" :nicknames '("CL") :use nil)
388
389 (let ((cl (find-package "CL"))
390 (lisp (find-package "LISP")))
391 (do-external-symbols (sym lisp)
392 (unintern sym lisp)
393 (let ((syms (list sym)))
394 (import syms cl)
395 (export syms cl)
396 (import syms lisp)
397 (export syms lisp))))
398
399 (cl:use-package "CL" "LISP")
400
401 (in-package :cl-user)
402
403 ;;; end of file.

  ViewVC Help
Powered by ViewVC 1.1.5