source: branches/qres/ccl/lib/read.lisp @ 14259

Last change on this file since 14259 was 14052, checked in by gz, 9 years ago

Faster #n=/#n# from trunk (r13591)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 13.0 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20
21                         
22(define-condition simple-reader-error (reader-error simple-error) ()
23  (:report (lambda (c output-stream)
24             (format output-stream "Reader error ~a:~%~?"
25                     (stream-error-context c)
26                     (simple-condition-format-control c)
27                     (simple-condition-format-arguments c)))))
28
29(defun signal-reader-error (input-stream format-string &rest format-args)
30  (error 'simple-reader-error :stream input-stream
31         :format-control format-string :format-arguments format-args))
32
33#| ; Can't see any reason to leave this in
34(defun read-file-to-list (file &aux result)
35   ;(print-db (setq file (prepend-default-dir file)))   
36   (with-open-file (stream file :direction :input)
37       (setq result (read-file-to-list-aux stream)))
38   result)
39
40(defun read-file-to-list-aux (stream)
41   (if (eofp stream)
42        nil
43       (let ((form (read stream nil *eof-value* nil)))
44            ;(%print "just read " form)
45           (if (eq form *eof-value*)
46                nil
47               (cons form (read-file-to-list-aux stream))))))
48|#
49
50(set-dispatch-macro-character #\# #\*
51 (qlfun |#*-reader| (input-stream sub-char int 
52   &aux list list-length array array-length last-bit)
53  (declare (ignore sub-char))
54  (do* ((char (read-char input-stream nil nil t)
55              (read-char input-stream nil nil t))
56        (attr (%character-attribute char (rdtab.ttab *readtable*))
57              (%character-attribute char (rdtab.ttab *readtable*))))
58       ((or (null char)
59            (= $cht_tmac attr)
60            (= $cht_wsp attr))
61        (if char (unread-char char input-stream)))
62    (let ((number (- (char-code char) 48)))
63      (if (or (<= 0 number 1) *read-suppress*)
64          (setq list (cons number list))
65          (signal-reader-error input-stream "reader macro #* got illegal character ~S" char))))
66  (setq last-bit (car list))
67  (setq list (nreverse list))
68  (setq list-length (list-length list))
69  (if (not (integerp int))
70      (setq int list-length))
71  (cond (*read-suppress* nil)
72        ((and (= 0 list-length) (> int 0))
73         (signal-reader-error input-stream "reader macro #~S* needs something" int))
74        ((> list-length int)
75         (signal-reader-error input-stream "reader macro #~S* can't fit ~S" int list))
76        (t (setq array-length (if int int list-length))
77           (setq array (make-array array-length :element-type 'bit))
78           (do ((i 0 (1+ i))
79                (bit-list list (cdr bit-list)))
80               ((>= i array-length))
81             (aset array i (if bit-list
82                               (car bit-list)
83                               last-bit)))
84           array))))
85
86(set-dispatch-macro-character #\# #\A
87 (qlfun |#A-reader| (stream ignore dimensions)
88   (declare (ignore ignore))
89   (cond (*read-suppress*
90          (read stream () () t)
91          nil)
92         ((not dimensions)
93          (signal-reader-error stream "reader macro #A used without a rank integer"))
94         ((eql dimensions 0) ;0 dimensional array
95          (make-array nil :initial-contents (read-internal stream t nil t)))
96         ((and (integerp dimensions) (> dimensions 0)) 
97          (let ((init-list (read-internal stream t nil t)))
98            (cond ((not (typep init-list 'sequence))
99                   (signal-reader-error stream "The form following a #~SA reader macro should have been a sequence, but it was: ~S" dimensions init-list))
100                  ((= (length init-list) 0)
101                   (make-array (make-list dimensions :initial-element 0)))
102                  ((= dimensions 1)
103                   (make-array (length init-list) :initial-contents init-list))
104                  ((vectorp init-list)
105                   (let ((dlist (make-list dimensions)))
106                     (do ((dl dlist (cdr dl))
107                          (il init-list (svref il 0)))
108                         ((null dl))
109                       (if (vectorp il)
110                           (rplaca dl (length il))
111                           (signal-reader-error stream "Initial contents for #A is inconsistent with dimensions: #~SA~S" dimensions init-list)))
112                     (make-array dlist :initial-contents init-list)))
113                  ((listp init-list)
114                   (let ((dlist (make-list dimensions)))
115                     (do ((dl dlist (cdr dl))
116                          (il init-list (car il)))
117                         ((null dl))
118                       (if (listp il)
119                           (rplaca dl (list-length il))
120                           (signal-reader-error stream "Initial contents for #A is inconsistent with dimensions: #~SA~S" dimensions init-list)))
121                     (make-array dlist :initial-contents init-list)))
122                  (t
123                   (signal-reader-error stream "#~SA~S invalid." dimensions init-list)))))
124         (t (signal-reader-error stream "Dimensions argument to #A not a non-negative integer: ~S" dimensions)))))
125
126(set-dispatch-macro-character #\# #\S
127  (qlfun |#S-reader| (input-stream sub-char int &aux list sd)
128     (declare (ignore sub-char int))
129     (setq list (read-internal input-stream t nil t))
130     (unless *read-suppress*
131       (unless (and (consp list)
132                    (symbolp (%car list))
133                    (setq sd (gethash (%car list) %defstructs%))
134                    (setq sd (sd-constructor sd)))
135         (error "Can't initialize structure from ~S." list))
136       (let ((args ()) (plist (cdr list)))
137         (unless (plistp plist) (report-bad-arg plist '(satisfies plistp)))
138         (while plist
139           (push (make-keyword (pop plist)) args)
140           (push (pop plist) args))
141         (apply sd (nreverse args))))))
142
143;;;from slisp reader2.lisp, and apparently not touched in 20 years.
144(defun parse-integer (string &key (start 0) end
145                      (radix 10) junk-allowed)
146  "Examine the substring of string delimited by start and end
147  (default to the beginning and end of the string)  It skips over
148  whitespace characters and then tries to parse an integer. The
149  radix parameter must be between 2 and 36."
150  (flet ((parse-integer-not-integer-string (s)
151           (error 'parse-integer-not-integer-string :string s)))
152    (declare (inline parse-integer-not-integer-string))
153    (unless (typep string 'string)
154      (setq string (require-type string 'string)))
155    (setq end (check-sequence-bounds string start end))
156    (setq radix (%validate-radix radix))
157    (let ((index (do ((i start (1+ i)))
158                     ((= i end)
159                      (if junk-allowed
160                        (return-from parse-integer (values nil end))
161                        (parse-integer-not-integer-string string)))
162                   (unless (whitespacep (char string i)) (return i))))
163        (minusp nil)
164        (found-digit nil)
165        (result 0))
166       (let ((char (char string index)))
167            (cond ((char= char #\-)
168                   (setq minusp t)
169                   (setq index (1+ index)))
170                  ((char= char #\+)
171                    (setq index (1+ index))
172                   )))
173       (loop
174        (when (= index end) (return nil))
175        (let* ((char (char string index))
176               (weight (digit-char-p char radix)))
177              (cond (weight
178                     (setq result (+ weight (* result radix))
179                                  found-digit t))
180                    (junk-allowed (return nil))
181                    ((whitespacep char)
182                     (until (eq (setq index (1+ index)) end)
183                       (unless (whitespacep (char string index))
184                         (parse-integer-not-integer-string string)))
185                     (return nil))
186                    (t
187                     (parse-integer-not-integer-string string))))
188         (setq index (1+ index)))
189       (values
190        (if found-digit
191            (if minusp (- result) result)
192            (if junk-allowed
193                nil
194                (parse-integer-not-integer-string string)))
195        index))))
196
197
198(defun get-read-object (arg)
199  (if (listp %read-objects%)
200    (assoc arg %read-objects%)
201    (gethash arg %read-objects%)))
202
203(defparameter *read-objects-hash-threshold* 30)
204
205(defun note-read-object (data)
206  (let* ((lab (car data)))
207    (if (get-read-object lab)
208      (%err-disp $xduprdlbl lab)
209      (if (listp %read-objects%)
210        (if (< (length %read-objects%) *read-objects-hash-threshold*)
211          (push data %read-objects%)
212          (let* ((hash (make-hash-table :test #'eql :shared nil :rehash-size 2.0)))
213            (dolist (info %read-objects%)
214              (let* ((lab (car info)))
215                (setf (gethash lab hash) info)))
216            (setf (gethash lab hash) data)
217            (setq %read-objects% hash)))
218        (setf (gethash lab %read-objects%) data)))))
219
220
221   
222
223(set-dispatch-macro-character #\# #\#
224  #'(lambda (stream char arg)
225      (declare (ignore stream))
226      (if *read-suppress* 
227        nil
228        (if arg
229          (let ((pair (get-read-object arg)))
230            (if pair
231              (let* ((cell (cdr pair)))
232                (setf (car cell) t)
233                (cdr cell))
234              (%err-disp $xnordlbl arg)))
235          (%err-disp $xrdndarg char)))))
236
237(set-dispatch-macro-character 
238 #\# 
239 #\=
240 #'(lambda (stream char arg &aux lab form)
241     (cond (*read-suppress* (values))
242           ((null arg) (%err-disp $xrdndarg char))
243           (t (setq lab (cons arg nil))
244              (%rplacd lab (cons nil lab))
245              (note-read-object lab)
246              (setq form (read stream t nil t))
247              (when (eq form lab)       ;#n= #n#.  No can do.
248                (%err-disp $xnordlbl (%car lab)))
249              (%rplacd (cdr lab) form)
250              (let* ((reffed (cadr lab)))
251                (if (not reffed)
252                  form
253                  (let ((scanned nil))
254                    (labels ((circle-subst (tree)
255                               (if (eq tree lab)
256                                 (progn
257                                   (unless (memq tree scanned)
258                                     (setq scanned (%temp-cons tree scanned))
259                                     (circle-subst (cddr tree)))
260                                   (cddr tree))
261                                 (progn
262                                   (cond ((consp tree)
263                                          (unless (memq tree scanned)
264                                            (push tree scanned)
265                                            (locally 
266                                                (declare (type cons tree))
267                                              (let* ((orig (car tree))
268                                                     (new (circle-subst orig)))
269                                                (unless (eq orig new)
270                                                  (rplaca tree new))
271                                                (setq orig (cdr tree)
272                                                      new (circle-subst orig))
273                                                (unless (eq orig new)
274                                                  (rplacd tree new))))))
275                                         ((let* ((typecode (typecode tree)))
276                                            (declare (type (unsigned-byte 8) typecode))
277                                            (or (= typecode target::subtag-simple-vector)
278                                                (= typecode target::subtag-struct)
279                                                (= typecode target::subtag-arrayH)))
280                                          (unless (memq tree scanned)
281                                            (push tree scanned)
282                                            (let* ((n (uvsize tree)))
283                                              (declare (fixnum n))
284                                              (do* ((i (if (eql (typecode tree) target::subtag-struct) 1 0) (1+ i)))
285                                                   ((= i n))
286                                                (declare (fixnum i))
287                                                (let* ((old (%svref tree i))
288                                                       (new (circle-subst old)))
289                                               (unless (eq old new)
290                                                 (setf (%svref tree i) new))))))))
291                                   tree))))
292                      (declare (dynamic-extent #'circle-subst))
293                      (circle-subst form)))))))))
294
295
296
Note: See TracBrowser for help on using the repository browser.