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

Contents of /src/code/sharpm.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (show annotations)
Tue Apr 20 17:57:45 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.29: +28 -28 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; 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/sharpm.lisp,v 1.30 2010/04/20 17:57:45 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Spice Lisp Interim Sharp Macro
13 ;;; Written by David Dill
14 ;;; Runs in the standard Spice Lisp environment.
15 ;;; This uses the special std-lisp-readtable, which is internal to READER.LISP
16 ;;;
17 (in-package "LISP")
18 (intl:textdomain "cmucl")
19
20 (export '(*read-eval*))
21
22
23 ;;; declared in READ.LISP
24
25 (declaim (special *read-suppress* std-lisp-readtable *bq-vector-flag*))
26
27 (defun ignore-numarg (sub-char numarg)
28 (when numarg
29 (warn (intl:gettext "Numeric argument ignored in #~D~A.") numarg sub-char)))
30
31 (defun sharp-backslash (stream backslash numarg)
32 (ignore-numarg backslash numarg)
33 (let ((charstring (read-extended-token-escaped stream)))
34 (declare (simple-string charstring))
35 (cond (*read-suppress* nil)
36 ((= (the fixnum (length charstring)) 1)
37 (char charstring 0))
38 ((name-char charstring))
39 (t
40 (%reader-error stream (intl:gettext "Unrecognized character name: ~S")
41 charstring)))))
42
43
44 (defun sharp-quote (stream sub-char numarg)
45 (ignore-numarg sub-char numarg)
46 ;; 4th arg tells read that this is a recrusive call.
47 `(function ,(read stream t nil t)))
48
49 (defun sharp-left-paren (stream ignore length)
50 (declare (ignore ignore) (special *backquote-count*))
51 (let* ((list (read-list stream nil)))
52 ;; Watch out for badly formed list (dotted list) and signal an
53 ;; error if so. Do we need to check for other kinds of badly
54 ;; formed lists?
55 (when (cdr (last list))
56 (%reader-error stream (intl:gettext "Ill-formed vector: #~S") list))
57 (let ((listlength (length list)))
58 (declare (list list)
59 (fixnum listlength))
60 (cond (*read-suppress* nil)
61 ((zerop *backquote-count*)
62 (if length
63 (cond ((> listlength (the fixnum length))
64 (%reader-error
65 stream
66 (intl:gettext "Vector longer than specified length: #~S~S")
67 length list))
68 (t
69 (fill (the simple-vector
70 (replace (the simple-vector
71 (make-array length))
72 list))
73 (car (last list))
74 :start listlength)))
75 (coerce list 'vector)))
76 (t (cons *bq-vector-flag* list))))))
77
78 (defun sharp-star (stream ignore numarg)
79 (declare (ignore ignore))
80 (multiple-value-bind (bstring escape-appearedp)
81 (read-extended-token stream)
82 (declare (simple-string bstring))
83 (cond (*read-suppress* nil)
84 (escape-appearedp
85 (%reader-error stream (intl:gettext "Escape character appeared after #*")))
86 ((and numarg (zerop (length bstring)) (not (zerop numarg)))
87 (%reader-error
88 stream
89 (intl:gettext "You have to give a little bit for non-zero #* bit-vectors.")))
90 ((or (null numarg) (>= (the fixnum numarg) (length bstring)))
91 (let* ((len1 (length bstring))
92 (last1 (1- len1))
93 (len2 (or numarg len1))
94 (bvec (make-array len2 :element-type 'bit
95 :initial-element 0)))
96 (declare (fixnum len1 last1 len2))
97 (do ((i 0 (1+ i))
98 (char ()))
99 ((= i len2))
100 (declare (fixnum i))
101 (setq char (elt bstring (if (< i len1) i last1)))
102 (setf (elt bvec i)
103 (cond ((char= char #\0) 0)
104 ((char= char #\1) 1)
105 (t
106 (%reader-error
107 stream
108 (intl:gettext "Illegal element given for bit-vector: ~S")
109 char)))))
110 bvec))
111 (t
112 (%reader-error stream
113 (intl:gettext "Bit vector is longer than specified length #~A*~A")
114 numarg bstring)))))
115
116
117 (defun sharp-colon (stream sub-char numarg)
118 (ignore-numarg sub-char numarg)
119 (multiple-value-bind (token escapep colon)
120 (read-extended-token stream)
121 (declare (simple-string token) (ignore escapep))
122 (cond
123 (*read-suppress* nil)
124 (colon
125 (%reader-error stream (intl:gettext "Symbol following #: contains a package marker: ~S")
126 token))
127 (t
128 (make-symbol token)))))
129
130 ;;;; #. handling.
131
132 (defvar *read-eval* t
133 "If false, then the #. read macro is disabled.")
134
135 (defun sharp-dot (stream sub-char numarg)
136 (ignore-numarg sub-char numarg)
137 (let ((token (read stream t nil t)))
138 (unless *read-suppress*
139 (unless *read-eval*
140 (%reader-error stream
141 (intl:gettext "Attempt to read #. while *READ-EVAL* is bound to NIL.")))
142 (eval token))))
143
144
145 ;;;; Numeric radix stuff:
146
147 (defun sharp-R (stream sub-char radix)
148 (cond (*read-suppress*
149 (read-extended-token stream)
150 nil)
151 ((not radix)
152 (%reader-error stream (intl:gettext "Radix missing in #R.")))
153 ((not (<= 2 radix 36))
154 (%reader-error stream (intl:gettext "Illegal radix for #R: ~D.") radix))
155 (t
156 (let ((res (let ((*read-base* radix))
157 (read stream t nil t))))
158 (unless (typep res 'rational)
159 (%reader-error stream (intl:gettext "#~A (base ~D) value is not a rational: ~S.")
160 sub-char radix res))
161 res))))
162
163 (defun sharp-B (stream sub-char numarg)
164 (ignore-numarg sub-char numarg)
165 (sharp-r stream sub-char 2))
166
167 (defun sharp-O (stream sub-char numarg)
168 (ignore-numarg sub-char numarg)
169 (sharp-r stream sub-char 8))
170
171 (defun sharp-X (stream sub-char numarg)
172 (ignore-numarg sub-char numarg)
173 (sharp-r stream sub-char 16))
174
175
176
177 (defun sharp-A (stream ignore dimensions)
178 (declare (ignore ignore))
179 (when *read-suppress*
180 (read stream t nil t)
181 (return-from sharp-A nil))
182 (cond (dimensions
183 (collect ((dims))
184 (let* ((contents (read stream t nil t))
185 (seq contents)
186 (zero-axis nil))
187 (dotimes (axis dimensions)
188 (unless (typep seq 'sequence)
189 (%reader-error stream
190 "#~DA axis ~D is not a sequence:~% ~S"
191 dimensions axis seq))
192 (let ((len (length seq)))
193 (dims len)
194 (unless (= axis (1- dimensions))
195 (cond ((zerop len)
196 (setq zero-axis axis))
197 (zero-axis
198 (%reader-error stream
199 (intl:gettext "#~DA axis ~D is empty, but axis ~
200 ~D is non-empty.")
201 dimensions zero-axis axis))
202 (t
203 (setq seq (elt seq 0)))))))
204 (make-array (dims) :initial-contents contents))))
205 (t
206 (destructuring-bind (element-type dims contents)
207 (read stream t nil t)
208 (make-array dims :element-type element-type
209 :initial-contents contents)))))
210
211 (defun sharp-S (stream sub-char numarg)
212 (ignore-numarg sub-char numarg)
213 ;;this needs to know about defstruct implementation
214 (when *read-suppress*
215 (read stream t nil t)
216 (return-from sharp-S nil))
217 (let ((body (if (char= (read-char stream t) #\( )
218 (read-list stream nil)
219 (%reader-error stream (intl:gettext "Non-list following #S")))))
220 (unless (listp body)
221 (%reader-error stream (intl:gettext "Non-list following #S: ~S") body))
222 (unless (symbolp (car body))
223 (%reader-error stream (intl:gettext "Structure type is not a symbol: ~S") (car body)))
224 (let ((class (kernel::find-class (car body) nil)))
225 (unless (typep class 'kernel::structure-class)
226 (%reader-error stream (intl:gettext "~S is not a defined structure type.")
227 (car body)))
228 (let ((def-con (dd-default-constructor
229 (layout-info
230 (%class-layout class)))))
231 (unless def-con
232 (%reader-error
233 stream (intl:gettext "The ~S structure does not have a default constructor.")
234 (car body)))
235 (apply (fdefinition def-con) (rest body))))))
236
237
238 ;;;; #=/##
239
240 ;;; Holds objects already seen by CIRCLE-SUBST.
241 ;;;
242 (defvar *sharp-equal-circle-table*)
243
244 ;; This function is kind of like to NSUBLIS, but checks for circularities and
245 ;; substitutes in arrays and structures as well as lists. The first arg is an
246 ;; alist of the things to be replaced assoc'd with the things to replace them.
247 ;;
248 (defun circle-subst (repl-table tree)
249 (cond ((not (typep tree '(or cons (array t) structure-object
250 standard-object)))
251 (multiple-value-bind (value presentp)
252 (gethash tree repl-table)
253 (if presentp
254 value
255 tree)))
256 ((null (gethash tree *sharp-equal-circle-table*))
257 (setf (gethash tree *sharp-equal-circle-table*) t)
258 (cond ((typep tree '(or structure-object standard-object))
259 (do ((i 1 (1+ i))
260 (end (%instance-length tree)))
261 ((= i end))
262 (let* ((old (%instance-ref tree i))
263 (new (circle-subst repl-table old)))
264 (unless (eq old new)
265 (setf (%instance-ref tree i) new)))))
266 ((arrayp tree)
267 (with-array-data ((data tree) (start) (end))
268 (declare (fixnum start end))
269 (do ((i start (1+ i)))
270 ((>= i end))
271 (let* ((old (aref data i))
272 (new (circle-subst repl-table old)))
273 (unless (eq old new)
274 (setf (aref data i) new))))))
275 (t
276 (let ((a (circle-subst repl-table (car tree)))
277 (d (circle-subst repl-table (cdr tree))))
278 (unless (eq a (car tree))
279 (rplaca tree a))
280 (unless (eq d (cdr tree))
281 (rplacd tree d)))))
282 tree)
283 (t tree)))
284
285 (defun maybe-create-tables ()
286 (unless *sharp-equal-final-table*
287 (setf *sharp-equal-final-table*
288 (make-hash-table :size 40 :rehash-size 4000 :rehash-threshold 0.8 :test 'eql)))
289 (unless *sharp-equal-temp-table*
290 (setf *sharp-equal-temp-table*
291 (make-hash-table :size 40 :rehash-size 4000 :rehash-threshold 0.8 :test 'eql)))
292 (unless *sharp-equal-repl-table*
293 (setf *sharp-equal-repl-table*
294 (make-hash-table :size 40 :rehash-size 4000 :rehash-threshold 0.8 :test 'eq))))
295
296 ;;; Sharp-equal works as follows. When a label is assigned (ie when #= is
297 ;;; called) we GENSYM a symbol is which is used as an unforgeable tag.
298 ;;; *SHARP-SHARP-ALIST* maps the integer tag to this gensym.
299 ;;;
300 ;;; When SHARP-SHARP encounters a reference to a label, it returns the symbol
301 ;;; assoc'd with the label. Resolution of the reference is deferred until the
302 ;;; read done by #= finishes. Any already resolved tags (in
303 ;;; *SHARP-EQUAL-ALIST*) are simply returned.
304 ;;;
305 ;;; After reading of the #= form is completed, we add an entry to
306 ;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved object. Then
307 ;;; for each entry in the *SHARP-SHARP-ALIST, the current object is searched
308 ;;; and any uses of the gensysm token are replaced with the actual value.
309 ;;;
310
311 ;;;
312 (defun sharp-equal (stream ignore label)
313 (declare (ignore ignore))
314 (when *read-suppress* (return-from sharp-equal (values)))
315 (unless label
316 (%reader-error stream (intl:gettext "Missing label for #=.") label))
317 (maybe-create-tables)
318 (when (or (nth-value 1 (gethash label *sharp-equal-final-table*))
319 (nth-value 1 (gethash label *sharp-equal-temp-table*)))
320 (%reader-error stream (intl:gettext "Multiply defined label: #~D=") label))
321 (let* ((tag (gensym)))
322 (setf (gethash label *sharp-equal-temp-table*) tag)
323 (let ((obj (read stream t nil t)))
324 (when (eq obj tag)
325 (%reader-error stream (intl:gettext "Have to tag something more than just #~D#.")
326 label))
327 (setf (gethash tag *sharp-equal-repl-table*) obj)
328 (let ((*sharp-equal-circle-table* (make-hash-table :test #'eq :size 20)))
329 (circle-subst *sharp-equal-repl-table* obj))
330 (setf (gethash label *sharp-equal-final-table*) obj))))
331 ;;;
332 (defun sharp-sharp (stream ignore label)
333 (declare (ignore ignore))
334 (when *read-suppress* (return-from sharp-sharp nil))
335 (unless label
336 (%reader-error stream (intl:gettext "Missing label for ##.") label))
337
338 (maybe-create-tables)
339 ;; Don't read ANSI "2.4.8.15 Sharpsign Equal-Sign" and worry that it requires
340 ;; you to implement forward references, because forward references are
341 ;; disallowed in "2.4.8.16 Sharpsign Sharpsign".
342 (multiple-value-bind (finalized-object successp)
343 (gethash label *sharp-equal-final-table*)
344 (if successp
345 finalized-object
346 (multiple-value-bind (temporary-tag successp)
347 (gethash label *sharp-equal-temp-table*)
348 (if successp
349 temporary-tag
350 (%reader-error stream (intl:gettext "reference to undefined label #~D#") label))))))
351
352 ;;;; #+/-
353
354 (flet ((guts (stream not-p)
355 (unless (if (handler-case
356 (let ((*package* *keyword-package*)
357 (*read-suppress* nil))
358 (featurep (read stream t nil t)))
359 (reader-package-error
360 (condition)
361 (declare (ignore condition))
362 nil))
363 (not not-p)
364 not-p)
365 (let ((*read-suppress* t))
366 (read stream t nil t)))
367 (values)))
368
369 (defun sharp-plus (stream sub-char numarg)
370 (ignore-numarg sub-char numarg)
371 (guts stream nil))
372
373 (defun sharp-minus (stream sub-char numarg)
374 (ignore-numarg sub-char numarg)
375 (guts stream t)))
376
377 (defun sharp-C (stream sub-char numarg)
378 (ignore-numarg sub-char numarg)
379 ;;next thing better be a list of two numbers.
380 (let ((cnum (read stream t nil t)))
381 (when *read-suppress* (return-from sharp-c nil))
382 (if (and (listp cnum) (= (length cnum) 2))
383 (complex (car cnum) (cadr cnum))
384 (%reader-error stream (intl:gettext "Illegal complex number format: #C~S") cnum))))
385
386 (defun sharp-vertical-bar (stream sub-char numarg)
387 (ignore-numarg sub-char numarg)
388 (let ((stream (in-synonym-of stream)))
389 (if (lisp-stream-p stream)
390 (prepare-for-fast-read-char stream
391 (do ((level 1)
392 (prev (fast-read-char) char)
393 (char (fast-read-char) (fast-read-char)))
394 (())
395 (cond ((and (char= prev #\|) (char= char #\#))
396 (setq level (1- level))
397 (when (zerop level)
398 (done-with-fast-read-char)
399 (return (values)))
400 (setq char (fast-read-char)))
401 ((and (char= prev #\#) (char= char #\|))
402 (setq char (fast-read-char))
403 (setq level (1+ level))))))
404 ;; Fundamental-stream.
405 (do ((level 1)
406 (prev (read-char stream t) char)
407 (char (read-char stream t) (read-char stream t)))
408 (())
409 (cond ((and (char= prev #\|) (char= char #\#))
410 (setq level (1- level))
411 (when (zerop level)
412 (return (values)))
413 (setq char (read-char stream t)))
414 ((and (char= prev #\#) (char= char #\|))
415 (setq char (read-char stream t))
416 (setq level (1+ level))))))))
417
418 (defun sharp-illegal (stream sub-char ignore)
419 (declare (ignore ignore))
420 (%reader-error stream (intl:gettext "Illegal sharp character ~S") sub-char))
421
422 (defun sharp-P (stream sub-char numarg)
423 (ignore-numarg sub-char numarg)
424 (let ((namestring (read stream t nil t)))
425 (unless *read-suppress*
426 (if (listp namestring)
427 ;; A CMUCL extension: #P(foo) treats foo as the args to
428 ;; make-pathname
429 (apply #'make-pathname namestring)
430 (parse-namestring namestring)))))
431
432 (make-dispatch-macro-character #\# t)
433 (set-dispatch-macro-character #\# #\\ #'sharp-backslash)
434 (set-dispatch-macro-character #\# #\' #'sharp-quote)
435 (set-dispatch-macro-character #\# #\( #'sharp-left-paren)
436 (set-dispatch-macro-character #\# #\* #'sharp-star)
437 (set-dispatch-macro-character #\# #\: #'sharp-colon)
438 (set-dispatch-macro-character #\# #\. #'sharp-dot)
439 (set-dispatch-macro-character #\# #\R #'sharp-R)
440 (set-dispatch-macro-character #\# #\r #'sharp-R)
441 (set-dispatch-macro-character #\# #\B #'sharp-B)
442 (set-dispatch-macro-character #\# #\b #'sharp-B)
443 (set-dispatch-macro-character #\# #\O #'sharp-O)
444 (set-dispatch-macro-character #\# #\o #'sharp-O)
445 (set-dispatch-macro-character #\# #\X #'sharp-X)
446 (set-dispatch-macro-character #\# #\x #'sharp-X)
447 (set-dispatch-macro-character #\# #\A #'sharp-A)
448 (set-dispatch-macro-character #\# #\a #'sharp-A)
449 (set-dispatch-macro-character #\# #\S #'sharp-S)
450 (set-dispatch-macro-character #\# #\s #'sharp-S)
451 (set-dispatch-macro-character #\# #\= #'sharp-equal)
452 (set-dispatch-macro-character #\# #\# #'sharp-sharp)
453 (set-dispatch-macro-character #\# #\+ #'sharp-plus)
454 (set-dispatch-macro-character #\# #\- #'sharp-minus)
455 (set-dispatch-macro-character #\# #\C #'sharp-C)
456 (set-dispatch-macro-character #\# #\c #'sharp-C)
457 (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
458 (set-dispatch-macro-character #\# #\p #'sharp-p)
459 (set-dispatch-macro-character #\# #\P #'sharp-p)
460 (set-dispatch-macro-character #\# #\tab #'sharp-illegal)
461 (set-dispatch-macro-character #\# #\ #'sharp-illegal)
462 (set-dispatch-macro-character #\# #\) #'sharp-illegal)
463 (set-dispatch-macro-character #\# #\< #'sharp-illegal)
464 (set-dispatch-macro-character #\# #\form #'sharp-illegal)
465 (set-dispatch-macro-character #\# #\return #'sharp-illegal)

  ViewVC Help
Powered by ViewVC 1.1.5