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