1.0.4.49: revert debugger hackery
[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 (handler-case (length list)
25                        (type-error
26                         (error)
27                         (declare (ignore error))
28                         (%reader-error stream "improper list in #(): ~S"
29                                        list)))))
30     (declare (list list)
31              (fixnum listlength))
32     (cond (*read-suppress* nil)
33           ((zerop *backquote-count*)
34            (if length
35                (cond ((> listlength (the fixnum length))
36                       (%reader-error
37                        stream
38                        "vector longer than specified length: #~S~S"
39                        length list))
40                      (t
41                       (fill (the simple-vector
42                                  (replace (the simple-vector
43                                                (make-array length))
44                                           list))
45                             (car (last list))
46                             :start listlength)))
47                (coerce list 'vector)))
48           (t (cons *bq-vector-flag* list)))))
49
50 (defun sharp-star (stream ignore numarg)
51   (declare (ignore ignore))
52   (multiple-value-bind (bstring escape-appearedp) (read-extended-token stream)
53     (declare (simple-string bstring))
54     (cond (*read-suppress* nil)
55           (escape-appearedp
56            (%reader-error stream "An escape character appeared after #*"))
57           ((and numarg (zerop (length bstring)) (not (zerop numarg)))
58            (%reader-error
59             stream
60             "You have to give a little bit for non-zero #* bit-vectors."))
61           ((or (null numarg) (>= (the fixnum numarg) (length bstring)))
62            (let* ((len1 (length bstring))
63                   (last1 (1- len1))
64                   (len2 (or numarg len1))
65                   (bvec (make-array len2 :element-type 'bit
66                                     :initial-element 0)))
67              (declare (fixnum len1 last1 len2))
68              (do ((i 0 (1+ i))
69                   (char ()))
70                  ((= i len2))
71                (declare (fixnum i))
72                (setq char (elt bstring (if (< i len1) i last1)))
73                (setf (elt bvec i)
74                      (cond ((char= char #\0) 0)
75                            ((char= char #\1) 1)
76                            (t
77                             (%reader-error
78                              stream
79                              "illegal element given for bit-vector: ~S"
80                              char)))))
81              bvec))
82           (t
83            (%reader-error stream
84                          "Bit vector is longer than specified length #~A*~A"
85                          numarg bstring)))))
86
87 (defun sharp-A (stream ignore dimensions)
88   (declare (ignore ignore))
89   (when *read-suppress*
90     (read stream t nil t)
91     (return-from sharp-A nil))
92   (unless dimensions (%reader-error stream "no dimensions argument to #A"))
93   (collect ((dims))
94     (let* ((contents (read stream t nil t))
95            (seq contents))
96       (dotimes (axis dimensions
97                      (make-array (dims) :initial-contents contents))
98         (unless (typep seq 'sequence)
99           (%reader-error stream
100                          "#~WA axis ~W is not a sequence:~%  ~S"
101                          dimensions axis seq))
102         (let ((len (length seq)))
103           (dims len)
104           (unless (or (= axis (1- dimensions))
105                       ;; ANSI: "If some dimension of the array whose
106                       ;; representation is being parsed is found to be
107                       ;; 0, all dimensions to the right (i.e., the
108                       ;; higher numbered dimensions) are also
109                       ;; considered to be 0."
110                       (= len 0))
111             (setq seq (elt seq 0))))))))
112 \f
113 ;;;; reading structure instances: the #S readmacro
114
115 (defun sharp-S (stream sub-char numarg)
116   (ignore-numarg sub-char numarg)
117   (when *read-suppress*
118     (read stream t nil t)
119     (return-from sharp-S nil))
120   (let ((body (if (char= (read-char stream t) #\( )
121                   (read-list stream nil)
122                   (%reader-error stream "non-list following #S"))))
123     (unless (listp body)
124       (%reader-error stream "non-list following #S: ~S" body))
125     (unless (symbolp (car body))
126       (%reader-error stream "Structure type is not a symbol: ~S" (car body)))
127     (let ((classoid (find-classoid (car body) nil)))
128       (unless (typep classoid 'structure-classoid)
129         (%reader-error stream "~S is not a defined structure type."
130                        (car body)))
131       (let ((def-con (dd-default-constructor
132                       (layout-info
133                        (classoid-layout classoid)))))
134         (unless def-con
135           (%reader-error
136            stream "The ~S structure does not have a default constructor."
137            (car body)))
138         (when (and (atom (rest body))
139                    (not (null (rest body))))
140           (%reader-error
141            stream "improper list for #S: ~S." body))
142         (apply (fdefinition def-con)
143                (loop for tail on (rest body) by #'cddr
144                      with slot-name = (and (consp tail) (car tail))
145                      do (progn
146                           (when (null (cdr tail))
147                             (%reader-error
148                              stream
149                              "the arglist for the ~S constructor in #S ~
150                               has an odd length: ~S."
151                              (car body) (rest body)))
152                           (when (or (atom (cdr tail))
153                                     (and (atom (cddr tail))
154                                          (not (null (cddr tail)))))
155                             (%reader-error
156                              stream
157                              "the arglist for the ~S constructor in #S ~
158                               is improper: ~S."
159                              (car body) (rest body)))
160                           (when (not (typep (car tail) 'string-designator))
161                             (%reader-error
162                              stream
163                              "a slot name in #S is not a string ~
164                               designator: ~S."
165                              slot-name))
166                           (when (not (keywordp slot-name))
167                             (warn 'structure-initarg-not-keyword
168                                   :format-control
169                                   "in #S ~S, the use of non-keywords ~
170                                    as slot specifiers is deprecated: ~S."
171                                   :format-arguments
172                                   (list (car body) slot-name))))
173                      collect (intern (string (car tail)) *keyword-package*)
174                      collect (cadr tail)))))))
175 \f
176 ;;;; reading numbers: the #B, #C, #O, #R, and #X readmacros
177
178 (defun sharp-B (stream sub-char numarg)
179   (ignore-numarg sub-char numarg)
180   (sharp-R stream sub-char 2))
181
182 (defun sharp-C (stream sub-char numarg)
183   (ignore-numarg sub-char numarg)
184   ;; The next thing had better be a list of two numbers.
185   (let ((cnum (read stream t nil t)))
186     (when *read-suppress* (return-from sharp-C nil))
187     (if (and (listp cnum) (= (length cnum) 2))
188         (complex (car cnum) (cadr cnum))
189         (%reader-error stream "illegal complex number format: #C~S" cnum))))
190
191 (defun sharp-O (stream sub-char numarg)
192   (ignore-numarg sub-char numarg)
193   (sharp-R stream sub-char 8))
194
195 (defun sharp-R (stream sub-char radix)
196   (cond (*read-suppress*
197          (read-extended-token stream)
198          nil)
199         ((not radix)
200          (%reader-error stream "radix missing in #R"))
201         ((not (<= 2 radix 36))
202          (%reader-error stream "illegal radix for #R: ~D." radix))
203         (t
204          (let ((res (let ((*read-base* radix))
205                       (read stream t nil t))))
206            (unless (typep res 'rational)
207              (%reader-error stream
208                             "#~A (base ~D.) value is not a rational: ~S."
209                             sub-char
210                             radix
211                             res))
212            res))))
213
214 (defun sharp-X (stream sub-char numarg)
215   (ignore-numarg sub-char numarg)
216   (sharp-R stream sub-char 16))
217 \f
218 ;;;; reading circular data: the #= and ## readmacros
219
220 ;;; objects already seen by CIRCLE-SUBST
221 (defvar *sharp-equal-circle-table*)
222 (declaim (type hash-table *sharp-equal-circle-table*))
223
224 ;; This function is kind of like NSUBLIS, but checks for circularities and
225 ;; substitutes in arrays and structures as well as lists. The first arg is an
226 ;; alist of the things to be replaced assoc'd with the things to replace them.
227 (defun circle-subst (old-new-alist tree)
228   (cond ((not (typep tree '(or cons (array t) instance funcallable-instance)))
229          (let ((entry (find tree old-new-alist :key #'second)))
230            (if entry (third entry) tree)))
231         ((null (gethash tree *sharp-equal-circle-table*))
232          (setf (gethash tree *sharp-equal-circle-table*) t)
233          (cond ((consp tree)
234                 (let ((a (circle-subst old-new-alist (car tree)))
235                       (d (circle-subst old-new-alist (cdr tree))))
236                   (unless (eq a (car tree))
237                     (rplaca tree a))
238                   (unless (eq d (cdr tree))
239                     (rplacd tree d))))
240                ((arrayp tree)
241                 (with-array-data ((data tree) (start) (end))
242                   (declare (fixnum start end))
243                   (do ((i start (1+ i)))
244                       ((>= i end))
245                     (let* ((old (aref data i))
246                            (new (circle-subst old-new-alist old)))
247                       (unless (eq old new)
248                         (setf (aref data i) new))))))
249                ((typep tree 'instance)
250                 (do ((i 1 (1+ i))
251                      (end (%instance-length tree)))
252                     ((= i end))
253                   (let* ((old (%instance-ref tree i))
254                          (new (circle-subst old-new-alist old)))
255                     (unless (eq old new)
256                       (setf (%instance-ref tree i) new)))))
257                ((typep tree 'funcallable-instance)
258                 (do ((i 1 (1+ i))
259                      (end (- (1+ (get-closure-length tree)) sb!vm:funcallable-instance-info-offset)))
260                     ((= i end))
261                   (let* ((old (%funcallable-instance-info tree i))
262                          (new (circle-subst old-new-alist old)))
263                     (unless (eq old new)
264                       (setf (%funcallable-instance-info tree i) new))))))
265          tree)
266         (t tree)))
267
268 ;;; Sharp-equal works as follows. When a label is assigned (i.e. when
269 ;;; #= is called) we GENSYM a symbol is which is used as an
270 ;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this
271 ;;; gensym.
272 ;;;
273 ;;; When SHARP-SHARP encounters a reference to a label, it returns the
274 ;;; symbol assoc'd with the label. Resolution of the reference is
275 ;;; deferred until the read done by #= finishes. Any already resolved
276 ;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned.
277 ;;;
278 ;;; After reading of the #= form is completed, we add an entry to
279 ;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved
280 ;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current
281 ;;; object is searched and any uses of the gensysm token are replaced
282 ;;; with the actual value.
283 (defvar *sharp-sharp-alist* ())
284
285 (defun sharp-equal (stream ignore label)
286   (declare (ignore ignore))
287   (when *read-suppress* (return-from sharp-equal (values)))
288   (unless label
289     (%reader-error stream "missing label for #=" label))
290   (when (or (assoc label *sharp-sharp-alist*)
291             (assoc label *sharp-equal-alist*))
292     (%reader-error stream "multiply defined label: #~D=" label))
293   (let* ((tag (gensym))
294          (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*))
295          (obj (read stream t nil t)))
296     (when (eq obj tag)
297       (%reader-error stream
298                      "must tag something more than just #~D#"
299                      label))
300     (push (list label tag obj) *sharp-equal-alist*)
301     (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20)))
302       (circle-subst *sharp-equal-alist* obj))))
303
304 (defun sharp-sharp (stream ignore label)
305   (declare (ignore ignore))
306   (when *read-suppress* (return-from sharp-sharp nil))
307   (unless label
308     (%reader-error stream "missing label for ##" label))
309
310   (let ((entry (assoc label *sharp-equal-alist*)))
311     (if entry
312         (third entry)
313         (let (;; Has this label been defined previously? (Don't read
314               ;; ANSI "2.4.8.15 Sharpsign Equal-Sign" and worry that
315               ;; it requires you to implement forward references,
316               ;; because forward references are disallowed in
317               ;; "2.4.8.16 Sharpsign Sharpsign".)
318               (pair (assoc label *sharp-sharp-alist*)))
319           (unless pair
320             (%reader-error stream "reference to undefined label #~D#" label))
321           (cdr pair)))))
322 \f
323 ;;;; conditional compilation: the #+ and #- readmacros
324
325 (flet ((guts (stream not-p)
326          (unless (if (let ((*package* *keyword-package*)
327                            (*read-suppress* nil))
328                        (featurep (read stream t nil t)))
329                      (not not-p)
330                      not-p)
331            (let ((*read-suppress* t))
332              (read stream t nil t)))
333          (values)))
334
335   (defun sharp-plus (stream sub-char numarg)
336     (ignore-numarg sub-char numarg)
337     (guts stream nil))
338
339   (defun sharp-minus (stream sub-char numarg)
340     (ignore-numarg sub-char numarg)
341     (guts stream t)))
342 \f
343 ;;;; reading miscellaneous objects: the #P, #\, and #| readmacros
344
345 (defun sharp-P (stream sub-char numarg)
346   (ignore-numarg sub-char numarg)
347   (let ((namestring (read stream t nil t)))
348     (unless *read-suppress*
349       (parse-namestring namestring))))
350
351 (defun sharp-backslash (stream backslash numarg)
352   (ignore-numarg backslash numarg)
353   (let ((charstring (read-extended-token-escaped stream)))
354     (declare (simple-string charstring))
355     (cond (*read-suppress* nil)
356           ((= (the fixnum (length charstring)) 1)
357            (char charstring 0))
358           ((name-char charstring))
359           (t
360            (%reader-error stream "unrecognized character name: ~S"
361                           charstring)))))
362
363 (defun sharp-vertical-bar (stream sub-char numarg)
364   (ignore-numarg sub-char numarg)
365   (handler-bind
366       ((character-decoding-error
367         #'(lambda (decoding-error)
368             (declare (ignorable decoding-error))
369             (style-warn "Character decoding error in a #|-comment at position ~A reading source file ~A, resyncing." (file-position stream) stream)
370             (invoke-restart 'attempt-resync))))
371     (let ((stream (in-synonym-of stream)))
372       (if (ansi-stream-p stream)
373           (prepare-for-fast-read-char stream
374             (do ((level 1)
375                  (prev (fast-read-char) char)
376                  (char (fast-read-char) (fast-read-char)))
377                 (())
378               (cond ((and (char= prev #\|) (char= char #\#))
379                      (setq level (1- level))
380                      (when (zerop level)
381                        (done-with-fast-read-char)
382                        (return (values)))
383                      (setq char (fast-read-char)))
384                     ((and (char= prev #\#) (char= char #\|))
385                      (setq char (fast-read-char))
386                      (setq level (1+ level))))))
387           ;; fundamental-stream
388           (do ((level 1)
389                (prev (read-char stream t) char)
390                (char (read-char stream t) (read-char stream t)))
391               (())
392             (cond ((and (char= prev #\|) (char= char #\#))
393                    (setq level (1- level))
394                    (when (zerop level)
395                      (return (values)))
396                    (setq char (read-char stream t)))
397                   ((and (char= prev #\#) (char= char #\|))
398                    (setq char (read-char stream t))
399                    (setq level (1+ level)))))))))
400 \f
401 ;;;; a grab bag of other sharp readmacros: #', #:, and #.
402
403 (defun sharp-quote (stream sub-char numarg)
404   (ignore-numarg sub-char numarg)
405   ;; The fourth arg tells READ that this is a recursive call.
406   `(function ,(read stream t nil t)))
407
408 (defun sharp-colon (stream sub-char numarg)
409   (ignore-numarg sub-char numarg)
410   (multiple-value-bind (token escapep colon) (read-extended-token stream)
411     (declare (simple-string token) (ignore escapep))
412     (cond
413      (*read-suppress* nil)
414      (colon
415       (%reader-error stream
416                      "The symbol following #: contains a package marker: ~S"
417                      token))
418      (t
419       (make-symbol token)))))
420
421 (defvar *read-eval* t
422   #!+sb-doc
423   "If false, then the #. read macro is disabled.")
424
425 (defun sharp-dot (stream sub-char numarg)
426   (ignore-numarg sub-char numarg)
427   (let ((token (read stream t nil t)))
428     (unless *read-suppress*
429       (unless *read-eval*
430         (%reader-error stream "can't read #. while *READ-EVAL* is NIL"))
431       (eval token))))
432 \f
433 (defun sharp-illegal (stream sub-char ignore)
434   (declare (ignore ignore))
435   (%reader-error stream "illegal sharp macro character: ~S" sub-char))
436
437 ;;; for cold init: Install SHARPM stuff in the current *READTABLE*.
438 (defun !sharpm-cold-init ()
439   (make-dispatch-macro-character #\# t)
440   (set-dispatch-macro-character #\# #\\ #'sharp-backslash)
441   (set-dispatch-macro-character #\# #\' #'sharp-quote)
442   (set-dispatch-macro-character #\# #\( #'sharp-left-paren)
443   (set-dispatch-macro-character #\# #\* #'sharp-star)
444   (set-dispatch-macro-character #\# #\: #'sharp-colon)
445   (set-dispatch-macro-character #\# #\. #'sharp-dot)
446   (set-dispatch-macro-character #\# #\R #'sharp-R)
447   (set-dispatch-macro-character #\# #\r #'sharp-R)
448   (set-dispatch-macro-character #\# #\B #'sharp-B)
449   (set-dispatch-macro-character #\# #\b #'sharp-B)
450   (set-dispatch-macro-character #\# #\O #'sharp-O)
451   (set-dispatch-macro-character #\# #\o #'sharp-O)
452   (set-dispatch-macro-character #\# #\X #'sharp-X)
453   (set-dispatch-macro-character #\# #\x #'sharp-X)
454   (set-dispatch-macro-character #\# #\A #'sharp-A)
455   (set-dispatch-macro-character #\# #\a #'sharp-A)
456   (set-dispatch-macro-character #\# #\S #'sharp-S)
457   (set-dispatch-macro-character #\# #\s #'sharp-S)
458   (set-dispatch-macro-character #\# #\= #'sharp-equal)
459   (set-dispatch-macro-character #\# #\# #'sharp-sharp)
460   (set-dispatch-macro-character #\# #\+ #'sharp-plus)
461   (set-dispatch-macro-character #\# #\- #'sharp-minus)
462   (set-dispatch-macro-character #\# #\C #'sharp-C)
463   (set-dispatch-macro-character #\# #\c #'sharp-C)
464   (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
465   (set-dispatch-macro-character #\# #\p #'sharp-P)
466   (set-dispatch-macro-character #\# #\P #'sharp-P)
467   (set-dispatch-macro-character #\# #\) #'sharp-illegal)
468   (set-dispatch-macro-character #\# #\< #'sharp-illegal)
469   (set-dispatch-macro-character #\# #\Space #'sharp-illegal)
470   (dolist (cc '#.(list tab-char-code form-feed-char-code return-char-code
471                        line-feed-char-code backspace-char-code))
472     (set-dispatch-macro-character #\# (code-char cc) #'sharp-illegal)))