0.7.5.15:
[sbcl.git] / src / code / sharpm.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
9
10 (in-package "SB!IMPL")
11 \f
12 (declaim (special *read-suppress* *standard-readtable* *bq-vector-flag*))
13
14 ;;; FIXME: Is it standard to ignore numeric args instead of raising errors?
15 (defun ignore-numarg (sub-char numarg)
16   (when numarg
17     (warn "A numeric argument was ignored in #~W~A." numarg sub-char)))
18 \f
19 ;;;; reading arrays and vectors: the #(, #*, and #A readmacros
20
21 (defun sharp-left-paren (stream ignore length)
22   (declare (ignore ignore) (special *backquote-count*))
23   (let* ((list (read-list stream nil))
24          (listlength (length list)))
25     (declare (list list)
26              (fixnum listlength))
27     (cond (*read-suppress* nil)
28           ((zerop *backquote-count*)
29            (if length
30                (cond ((> listlength (the fixnum length))
31                       (%reader-error
32                        stream
33                        "vector longer than specified length: #~S~S"
34                        length list))
35                      (t
36                       (fill (the simple-vector
37                                  (replace (the simple-vector
38                                                (make-array length))
39                                           list))
40                             (car (last list))
41                             :start listlength)))
42                (coerce list 'vector)))
43           (t (cons *bq-vector-flag* list)))))
44
45 (defun sharp-star (stream ignore numarg)
46   (declare (ignore ignore))
47   (multiple-value-bind (bstring escape-appearedp) (read-extended-token stream)
48     (declare (simple-string bstring))
49     (cond (*read-suppress* nil)
50           (escape-appearedp
51            (%reader-error stream "An escape character appeared after #*"))
52           ((and numarg (zerop (length bstring)) (not (zerop numarg)))
53            (%reader-error
54             stream
55             "You have to give a little bit for non-zero #* bit-vectors."))
56           ((or (null numarg) (>= (the fixnum numarg) (length bstring)))
57            (let* ((len1 (length bstring))
58                   (last1 (1- len1))
59                   (len2 (or numarg len1))
60                   (bvec (make-array len2 :element-type 'bit
61                                     :initial-element 0)))
62              (declare (fixnum len1 last1 len2))
63              (do ((i 0 (1+ i))
64                   (char ()))
65                  ((= i len2))
66                (declare (fixnum i))
67                (setq char (elt bstring (if (< i len1) i last1)))
68                (setf (elt bvec i)
69                      (cond ((char= char #\0) 0)
70                            ((char= char #\1) 1)
71                            (t
72                             (%reader-error
73                              stream
74                              "illegal element given for bit-vector: ~S"
75                              char)))))
76              bvec))
77           (t
78            (%reader-error stream
79                          "Bit vector is longer than specified length #~A*~A"
80                          numarg bstring)))))
81
82 (defun sharp-A (stream ignore dimensions)
83   (declare (ignore ignore))
84   (when *read-suppress*
85     (read stream t nil t)
86     (return-from sharp-A nil))
87   (unless dimensions (%reader-error stream "no dimensions argument to #A"))
88   (collect ((dims))
89     (let* ((contents (read stream t nil t))
90            (seq contents))
91       (dotimes (axis dimensions
92                      (make-array (dims) :initial-contents contents))
93         (unless (typep seq 'sequence)
94           (%reader-error stream
95                          "#~WA axis ~W is not a sequence:~%  ~S"
96                          dimensions axis seq))
97         (let ((len (length seq)))
98           (dims len)
99           (unless (= axis (1- dimensions))
100             (when (zerop len)
101               (%reader-error stream
102                              "#~WA axis ~W is empty, but is not ~
103                               the last dimension."
104                              dimensions axis))
105             (setq seq (elt seq 0))))))))
106 \f
107 ;;;; reading structure instances: the #S readmacro
108
109 (defun sharp-S (stream sub-char numarg)
110   (ignore-numarg sub-char numarg)
111   (when *read-suppress*
112     (read stream t nil t)
113     (return-from sharp-S nil))
114   (let ((body (if (char= (read-char stream t) #\( )
115                   (read-list stream nil)
116                   (%reader-error stream "non-list following #S"))))
117     (unless (listp body)
118       (%reader-error stream "non-list following #S: ~S" body))
119     (unless (symbolp (car body))
120       (%reader-error stream "Structure type is not a symbol: ~S" (car body)))
121     (let ((class (sb!xc:find-class (car body) nil)))
122       (unless (typep class 'sb!xc:structure-class)
123         (%reader-error stream "~S is not a defined structure type."
124                        (car body)))
125       (let ((def-con (dd-default-constructor
126                       (layout-info
127                        (class-layout class)))))
128         (unless def-con
129           (%reader-error
130            stream "The ~S structure does not have a default constructor."
131            (car body)))
132         (apply (fdefinition def-con) (rest body))))))
133 \f
134 ;;;; reading numbers: the #B, #C, #O, #R, and #X readmacros
135
136 (defun sharp-B (stream sub-char numarg)
137   (ignore-numarg sub-char numarg)
138   (sharp-r stream sub-char 2))
139
140 (defun sharp-C (stream sub-char numarg)
141   (ignore-numarg sub-char numarg)
142   ;; The next thing had better be a list of two numbers.
143   (let ((cnum (read stream t nil t)))
144     (when *read-suppress* (return-from sharp-c nil))
145     (if (and (listp cnum) (= (length cnum) 2))
146         (complex (car cnum) (cadr cnum))
147         (%reader-error stream "illegal complex number format: #C~S" cnum))))
148
149 (defun sharp-O (stream sub-char numarg)
150   (ignore-numarg sub-char numarg)
151   (sharp-r stream sub-char 8))
152
153 (defun sharp-R (stream sub-char radix)
154   (cond (*read-suppress*
155          (read-extended-token stream)
156          nil)
157         ((not radix)
158          (%reader-error stream "radix missing in #R"))
159         ((not (<= 2 radix 36))
160          (%reader-error stream "illegal radix for #R: ~D." radix))
161         (t
162          (let ((res (let ((*read-base* radix))
163                       (read stream t nil t))))
164            (unless (typep res 'rational)
165              (%reader-error stream
166                             "#~A (base ~D.) value is not a rational: ~S."
167                             sub-char
168                             radix
169                             res))
170            res))))
171
172 (defun sharp-X (stream sub-char numarg)
173   (ignore-numarg sub-char numarg)
174   (sharp-r stream sub-char 16))
175 \f
176 ;;;; reading circular data: the #= and ## readmacros
177
178 ;;; objects already seen by CIRCLE-SUBST
179 (defvar *sharp-equal-circle-table*)
180 (declaim (type hash-table *sharp-equal-circle-table*))
181
182 ;; This function is kind of like NSUBLIS, but checks for circularities and
183 ;; substitutes in arrays and structures as well as lists. The first arg is an
184 ;; alist of the things to be replaced assoc'd with the things to replace them.
185 (defun circle-subst (old-new-alist tree)
186   (cond ((not (typep tree '(or cons (array t) structure-object)))
187          (let ((entry (find tree old-new-alist :key #'second)))
188            (if entry (third entry) tree)))
189         ((null (gethash tree *sharp-equal-circle-table*))
190          (setf (gethash tree *sharp-equal-circle-table*) t)
191          (cond ((typep tree 'structure-object)
192                 (do ((i 1 (1+ i))
193                      (end (%instance-length tree)))
194                     ((= i end))
195                   (let* ((old (%instance-ref tree i))
196                          (new (circle-subst old-new-alist old)))
197                     (unless (eq old new)
198                       (setf (%instance-ref tree i) new)))))
199                ((arrayp tree)
200                 (with-array-data ((data tree) (start) (end))
201                   (declare (fixnum start end))
202                   (do ((i start (1+ i)))
203                       ((>= i end))
204                     (let* ((old (aref data i))
205                            (new (circle-subst old-new-alist old)))
206                       (unless (eq old new)
207                         (setf (aref data i) new))))))
208                (t
209                 (let ((a (circle-subst old-new-alist (car tree)))
210                       (d (circle-subst old-new-alist (cdr tree))))
211                   (unless (eq a (car tree))
212                     (rplaca tree a))
213                   (unless (eq d (cdr tree))
214                     (rplacd tree d)))))
215          tree)
216         (t tree)))
217
218 ;;; Sharp-equal works as follows. When a label is assigned (i.e. when
219 ;;; #= is called) we GENSYM a symbol is which is used as an
220 ;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this
221 ;;; gensym.
222 ;;;
223 ;;; When SHARP-SHARP encounters a reference to a label, it returns the
224 ;;; symbol assoc'd with the label. Resolution of the reference is
225 ;;; deferred until the read done by #= finishes. Any already resolved
226 ;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned.
227 ;;;
228 ;;; After reading of the #= form is completed, we add an entry to
229 ;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved
230 ;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current
231 ;;; object is searched and any uses of the gensysm token are replaced
232 ;;; with the actual value.
233 (defvar *sharp-sharp-alist* ())
234
235 (defun sharp-equal (stream ignore label)
236   (declare (ignore ignore))
237   (when *read-suppress* (return-from sharp-equal (values)))
238   (unless label
239     (%reader-error stream "missing label for #=" label))
240   (when (or (assoc label *sharp-sharp-alist*)
241             (assoc label *sharp-equal-alist*))
242     (%reader-error stream "multiply defined label: #~D=" label))
243   (let* ((tag (gensym))
244          (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*))
245          (obj (read stream t nil t)))
246     (when (eq obj tag)
247       (%reader-error stream
248                      "must tag something more than just #~D#"
249                      label))
250     (push (list label tag obj) *sharp-equal-alist*)
251     (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20)))
252       (circle-subst *sharp-equal-alist* obj))))
253
254 (defun sharp-sharp (stream ignore label)
255   (declare (ignore ignore))
256   (when *read-suppress* (return-from sharp-sharp nil))
257   (unless label
258     (%reader-error stream "missing label for ##" label))
259
260   (let ((entry (assoc label *sharp-equal-alist*)))
261     (if entry
262         (third entry)
263         (let ((pair (assoc label *sharp-sharp-alist*)))
264           (unless pair
265             (%reader-error stream "object is not labelled #~S#" label))
266           (cdr pair)))))
267 \f
268 ;;;; conditional compilation: the #+ and #- readmacros
269
270 (flet ((guts (stream not-p)
271          (unless (if (handler-case
272                          (let ((*package* *keyword-package*)
273                                (*read-suppress* nil))
274                            (featurep (read stream t nil t)))
275                        (reader-package-error
276                         (condition)
277                         (declare (ignore condition))
278                         nil))
279                      (not not-p)
280                      not-p)
281            (let ((*read-suppress* t))
282              (read stream t nil t)))
283          (values)))
284
285   (defun sharp-plus (stream sub-char numarg)
286     (ignore-numarg sub-char numarg)
287     (guts stream nil))
288
289   (defun sharp-minus (stream sub-char numarg)
290     (ignore-numarg sub-char numarg)
291     (guts stream t)))
292 \f
293 ;;;; reading miscellaneous objects: the #P, #\, and #| readmacros
294
295 (defun sharp-P (stream sub-char numarg)
296   (ignore-numarg sub-char numarg)
297   (let ((namestring (read stream t nil t)))
298     (unless *read-suppress*
299       (parse-namestring namestring))))
300
301 (defun sharp-backslash (stream backslash numarg)
302   (ignore-numarg backslash numarg)
303   (let ((charstring (read-extended-token-escaped stream)))
304     (declare (simple-string charstring))
305     (cond (*read-suppress* nil)
306           ((= (the fixnum (length charstring)) 1)
307            (char charstring 0))
308           ((name-char charstring))
309           (t
310            (%reader-error stream "unrecognized character name: ~S"
311                           charstring)))))
312
313 (defun sharp-vertical-bar (stream sub-char numarg)
314   (ignore-numarg sub-char numarg)
315   (let ((stream (in-synonym-of stream)))
316     (if (ansi-stream-p stream)
317         (prepare-for-fast-read-char stream
318           (do ((level 1)
319                (prev (fast-read-char) char)
320                (char (fast-read-char) (fast-read-char)))
321               (())
322             (cond ((and (char= prev #\|) (char= char #\#))
323                    (setq level (1- level))
324                    (when (zerop level)
325                      (done-with-fast-read-char)
326                      (return (values)))
327                    (setq char (fast-read-char)))
328                   ((and (char= prev #\#) (char= char #\|))
329                    (setq char (fast-read-char))
330                    (setq level (1+ level))))))
331         ;; fundamental-stream
332         (do ((level 1)
333              (prev (read-char stream t) char)
334              (char (read-char stream t) (read-char stream t)))
335             (())
336           (cond ((and (char= prev #\|) (char= char #\#))
337                  (setq level (1- level))
338                  (when (zerop level)
339                    (return (values)))
340                  (setq char (read-char stream t)))
341                 ((and (char= prev #\#) (char= char #\|))
342                  (setq char (read-char stream t))
343                  (setq level (1+ level))))))))
344 \f
345 ;;;; a grab bag of other sharp readmacros: #', #:, and #.
346
347 (defun sharp-quote (stream sub-char numarg)
348   (ignore-numarg sub-char numarg)
349   ;; The fourth arg tells READ that this is a recursive call.
350   `(function ,(read stream t nil t)))
351
352 (defun sharp-colon (stream sub-char numarg)
353   (ignore-numarg sub-char numarg)
354   (multiple-value-bind (token escapep colon) (read-extended-token stream)
355     (declare (simple-string token) (ignore escapep))
356     (cond
357      (*read-suppress* nil)
358      (colon
359       (%reader-error stream
360                      "The symbol following #: contains a package marker: ~S"
361                      token))
362      (t
363       (make-symbol token)))))
364
365 (defvar *read-eval* t
366   #!+sb-doc
367   "If false, then the #. read macro is disabled.")
368
369 (defun sharp-dot (stream sub-char numarg)
370   (ignore-numarg sub-char numarg)
371   (let ((token (read stream t nil t)))
372     (unless *read-suppress*
373       (unless *read-eval*
374         (%reader-error stream "can't read #. while *READ-EVAL* is NIL"))
375       (eval token))))
376 \f
377 (defun sharp-illegal (stream sub-char ignore)
378   (declare (ignore ignore))
379   (%reader-error stream "illegal sharp macro character: ~S" sub-char))
380
381 ;;; for cold init: Install SHARPM stuff in the current *READTABLE*.
382 (defun !sharpm-cold-init ()
383   (make-dispatch-macro-character #\# t)
384   (set-dispatch-macro-character #\# #\\ #'sharp-backslash)
385   (set-dispatch-macro-character #\# #\' #'sharp-quote)
386   (set-dispatch-macro-character #\# #\( #'sharp-left-paren)
387   (set-dispatch-macro-character #\# #\* #'sharp-star)
388   (set-dispatch-macro-character #\# #\: #'sharp-colon)
389   (set-dispatch-macro-character #\# #\. #'sharp-dot)
390   (set-dispatch-macro-character #\# #\R #'sharp-R)
391   (set-dispatch-macro-character #\# #\r #'sharp-R)
392   (set-dispatch-macro-character #\# #\B #'sharp-B)
393   (set-dispatch-macro-character #\# #\b #'sharp-B)
394   (set-dispatch-macro-character #\# #\O #'sharp-O)
395   (set-dispatch-macro-character #\# #\o #'sharp-O)
396   (set-dispatch-macro-character #\# #\X #'sharp-X)
397   (set-dispatch-macro-character #\# #\x #'sharp-X)
398   (set-dispatch-macro-character #\# #\A #'sharp-A)
399   (set-dispatch-macro-character #\# #\a #'sharp-A)
400   (set-dispatch-macro-character #\# #\S #'sharp-S)
401   (set-dispatch-macro-character #\# #\s #'sharp-S)
402   (set-dispatch-macro-character #\# #\= #'sharp-equal)
403   (set-dispatch-macro-character #\# #\# #'sharp-sharp)
404   (set-dispatch-macro-character #\# #\+ #'sharp-plus)
405   (set-dispatch-macro-character #\# #\- #'sharp-minus)
406   (set-dispatch-macro-character #\# #\C #'sharp-C)
407   (set-dispatch-macro-character #\# #\c #'sharp-C)
408   (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
409   (set-dispatch-macro-character #\# #\p #'sharp-p)
410   (set-dispatch-macro-character #\# #\P #'sharp-p)
411   (set-dispatch-macro-character #\# #\) #'sharp-illegal)
412   (set-dispatch-macro-character #\# #\< #'sharp-illegal)
413   (set-dispatch-macro-character #\# #\Space #'sharp-illegal)
414   (dolist (cc '#.(list tab-char-code form-feed-char-code return-char-code
415                        line-feed-char-code backspace-char-code))
416     (set-dispatch-macro-character #\# (code-char cc) #'sharp-illegal)))