source: branches/working-0711/ccl/lib/read.lisp @ 8421

Last change on this file since 8421 was 8421, checked in by wws, 13 years ago

Marco's source-tracking-0801 branch passes tests on the customer system. Merge it here.

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