Remove references to non-symbol literals
[jscl.git] / src / read.lisp
1 ;;; read.lisp --- 
2
3 ;; Copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
5
6 ;; JSCL is free software: you can redistribute it and/or
7 ;; modify it under the terms of the GNU General Public License as
8 ;; published by the Free Software Foundation, either version 3 of the
9 ;; License, or (at your option) any later version.
10 ;;
11 ;; JSCL is distributed in the hope that it will be useful, but
12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14 ;; General Public License for more details.
15 ;;
16 ;; You should have received a copy of the GNU General Public License
17 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
18
19
20 ;;;; Reader
21
22 ;;; The Lisp reader, parse strings and return Lisp objects. The main
23 ;;; entry points are `ls-read' and `ls-read-from-string'.
24
25 (defun make-string-stream (string)
26   (cons string 0))
27
28 (defun %peek-char (stream)
29   (and (< (cdr stream) (length (car stream)))
30        (char (car stream) (cdr stream))))
31
32 (defun %read-char (stream)
33   (and (< (cdr stream) (length (car stream)))
34        (prog1 (char (car stream) (cdr stream))
35          (rplacd stream (1+ (cdr stream))))))
36
37 (defun whitespacep (ch)
38   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
39
40 (defun skip-whitespaces (stream)
41   (let (ch)
42     (setq ch (%peek-char stream))
43     (while (and ch (whitespacep ch))
44       (%read-char stream)
45       (setq ch (%peek-char stream)))))
46
47 (defun terminalp (ch)
48   (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
49
50 (defun read-until (stream func)
51   (let ((string "")
52         (ch))
53     (setq ch (%peek-char stream))
54     (while (and ch (not (funcall func ch)))
55       (setq string (concat string (string ch)))
56       (%read-char stream)
57       (setq ch (%peek-char stream)))
58     string))
59
60 (defun read-escaped-until (stream func)
61   (let ((string "")
62         (ch (%peek-char stream))
63         (multi-escape nil))
64     (while (and ch (or multi-escape (not (funcall func ch))))
65       (cond
66         ((char= ch #\|)
67          (if multi-escape
68              (setf multi-escape nil)
69              (setf multi-escape t)))
70         ((char= ch #\\)
71          (%read-char stream)
72          (setf ch (%peek-char stream))
73          (setf string (concat string "\\" (string ch))))
74         (t
75          (if multi-escape
76              (setf string (concat string "\\" (string ch)))
77              (setf string (concat string (string ch))))))
78       (%read-char stream)
79       (setf ch (%peek-char stream)))
80     string))
81
82 (defun skip-whitespaces-and-comments (stream)
83   (let (ch)
84     (skip-whitespaces stream)
85     (setq ch (%peek-char stream))
86     (while (and ch (char= ch #\;))
87       (read-until stream (lambda (x) (char= x #\newline)))
88       (skip-whitespaces stream)
89       (setq ch (%peek-char stream)))))
90
91 (defun %read-list (stream)
92   (skip-whitespaces-and-comments stream)
93   (let ((ch (%peek-char stream)))
94     (cond
95       ((null ch)
96        (error "Unspected EOF"))
97       ((char= ch #\))
98        (%read-char stream)
99        nil)
100       (t
101        (let ((car (ls-read-1 stream)))
102          (skip-whitespaces-and-comments stream)
103          (cons car
104                (if (char= (%peek-char stream) #\.)
105                    (progn
106                      (%read-char stream)
107                      (if (terminalp (%peek-char stream))
108                          (ls-read-1 stream) ; Dotted pair notation
109                          (cons (let ((string (concat "." (read-escaped-until stream #'terminalp))))
110                                  (or (values (!parse-integer string nil))
111                                      (read-float string)
112                                      (read-symbol string)))
113                                (%read-list stream))))
114                    (%read-list stream))))))))
115
116 (defun read-string (stream)
117   (let ((string "")
118         (ch nil))
119     (setq ch (%read-char stream))
120     (while (not (eql ch #\"))
121       (when (null ch)
122         (error "Unexpected EOF"))
123       (when (eql ch #\\)
124         (setq ch (%read-char stream)))
125       (setq string (concat string (string ch)))
126       (setq ch (%read-char stream)))
127     string))
128
129 (defun read-sharp (stream)
130   (%read-char stream)
131   (ecase (%read-char stream)
132     (#\'
133      (list 'function (ls-read-1 stream)))
134     (#\( (list-to-vector (%read-list stream)))
135     (#\: (make-symbol (string-upcase (read-until stream #'terminalp))))
136     (#\\
137      (let ((cname
138             (concat (string (%read-char stream))
139                     (read-until stream #'terminalp))))
140        (cond
141          ((string= cname "space") #\space)
142          ((string= cname "tab") #\tab)
143          ((string= cname "newline") #\newline)
144          (t (char cname 0)))))
145     (#\+
146      (let ((feature (read-until stream #'terminalp)))
147        (cond
148          ((string= feature "common-lisp")
149           (ls-read-1 stream)              ;ignore
150           (ls-read-1 stream))
151          ((string= feature "jscl")
152           (ls-read-1 stream))
153          (t
154           (error "Unknown reader form.")))))))
155
156 (defun unescape (x)
157   (let ((result ""))
158     (dotimes (i (length x))
159       (unless (char= (char x i) #\\)
160         (setq result (concat result (string (char x i))))))
161     result))
162
163 (defun escape-all (x)
164   (let ((result ""))
165     (dotimes (i (length x))
166       (setq result (concat result "\\"))
167       (setq result (concat result (string (char x i)))))
168     result))
169
170 (defun string-upcase-noescaped (s)
171   (let ((result "")
172         (last-escape nil))
173     (dotimes (i (length s))
174       (let ((ch (char s i)))
175         (if last-escape
176            (progn
177               (setf last-escape nil)
178               (setf result (concat result (string ch))))
179             (if (char= ch #\\)
180                 (setf last-escape t)
181                 (setf result (concat result (string-upcase (string ch))))))))
182     result))
183
184 ;;; Parse a string of the form NAME, PACKAGE:NAME or
185 ;;; PACKAGE::NAME and return the name. If the string is of the
186 ;;; form 1) or 3), but the symbol does not exist, it will be created
187 ;;; and interned in that package.
188 (defun read-symbol (string)
189   (let ((size (length string))
190         package name internalp index)
191     (setq index 0)
192     (while (and (< index size)
193                 (not (char= (char string index) #\:)))
194       (when (char= (char string index) #\\)
195         (incf index))
196       (incf index))
197     (cond
198       ;; No package prefix
199       ((= index size)
200        (setq name string)
201        (setq package *package*)
202        (setq internalp t))
203       (t
204        ;; Package prefix
205        (if (zerop index)
206            (setq package "KEYWORD")
207            (setq package (string-upcase-noescaped (subseq string 0 index))))
208        (incf index)
209        (when (char= (char string index) #\:)
210          (setq internalp t)
211          (incf index))
212        (setq name (subseq string index))))
213     ;; Canonalize symbol name and package
214     (setq name (if (equal package "JS")
215                    (setq name (unescape name))
216                    (setq name (string-upcase-noescaped name))))
217     (setq package (find-package package))
218     (if (or internalp
219             (eq package (find-package "KEYWORD"))
220             (eq package (find-package "JS")))
221         (intern name package)
222         (multiple-value-bind (symbol external)
223             (find-symbol name package)
224           (if (eq external :external)
225               symbol
226               (error "The symbol `~S' is not external in the package ~S." name package))))))
227
228 (defun read-integer (string)
229   (let ((sign 1)
230         (number nil)
231         (size (length string)))
232     (dotimes (i size)
233       (let ((elt (char string i)))
234         (cond
235           ((digit-char-p elt)
236            (setq number (+ (* (or number 0) 10) (digit-char-p elt))))
237           ((zerop i)
238            (case elt
239              (#\+ nil)
240              (#\- (setq sign -1))
241              (t (return-from read-integer))))
242           ((and (= i (1- size)) (char= elt #\.)) nil)
243           (t (return-from read-integer)))))
244     (and number (* sign number))))
245
246 (defun read-float (string)
247   (block nil
248     (let ((sign 1)
249           (integer-part nil)
250           (fractional-part nil)
251           (number 0)
252           (divisor 1)
253           (exponent-sign 1)
254           (exponent 0)
255           (size (length string))
256           (index 0))
257       (when (zerop size) (return))
258       ;; Optional sign
259       (case (char string index)
260         (#\+ (incf index))
261         (#\- (setq sign -1)
262              (incf index)))
263       (unless (< index size) (return))
264       ;; Optional integer part
265       (awhen (digit-char-p (char string index))
266         (setq integer-part t)
267         (while (and (< index size)
268                     (setq it (digit-char-p (char string index))))
269           (setq number (+ (* number 10) it))
270           (incf index)))
271       (unless (< index size) (return))
272       ;; Decimal point is mandatory if there's no integer part
273       (unless (or integer-part (char= #\. (char string index))) (return))
274       ;; Optional fractional part
275       (when (char= #\. (char string index))
276         (incf index)
277         (unless (< index size) (return))
278         (awhen (digit-char-p (char string index))
279           (setq fractional-part t)
280           (while (and (< index size)
281                       (setq it (digit-char-p (char string index))))
282             (setq number (+ (* number 10) it))
283             (setq divisor (* divisor 10))
284             (incf index))))
285       ;; Either left or right part of the dot must be present
286       (unless (or integer-part fractional-part) (return))
287       ;; Exponent is mandatory if there is no fractional part
288       (when (and (= index size) (not fractional-part)) (return))
289       ;; Optional exponent part
290       (when (< index size)
291         ;; Exponent-marker
292         (unless (member (string-upcase (string (char string index)))
293                         '("E" "S" "F" "D" "L"))
294           (return))
295         (incf index)
296         (unless (< index size) (return))
297         ;; Optional exponent sign
298         (case (char string index)
299           (#\+ (incf index))
300           (#\- (setq exponent-sign -1)
301                (incf index)))
302         (unless (< index size) (return))
303         ;; Exponent digits
304         (let ((value (digit-char-p (char string index))))
305           (unless value (return))
306           (while (and (< index size)
307                       (setq value (digit-char-p (char string index))))
308             (setq exponent (+ (* exponent 10) value))
309             (incf index))))
310       (unless (= index size) (return))
311       ;; Everything went ok, we have a float
312       ;; XXX: Use FLOAT when implemented.
313       (/ (* sign (expt 10.0 (* exponent-sign exponent)) number) divisor))))
314
315 (defun !parse-integer (string junk-allow)
316   (block nil
317     (let ((value 0)
318           (index 0)
319           (size (length string))
320           (sign 1))
321       ;; Leading whitespace
322       (while (and (< index size)
323                   (whitespacep (char string index)))
324         (incf index))
325       (unless (< index size) (return (values nil 0)))
326       ;; Optional sign
327       (case (char string 0)
328         (#\+ (incf index))
329         (#\- (setq sign -1)
330              (incf index)))
331       ;; First digit
332       (unless (and (< index size)
333                    (setq value (digit-char-p (char string index))))
334         (return (values nil index)))
335       (incf index)
336       ;; Other digits
337       (while (< index size)
338         (let ((digit (digit-char-p (char string index))))
339           (unless digit (return))
340           (setq value (+ (* value 10) digit))
341           (incf index)))
342       ;; Trailing whitespace
343       (do ((i index (1+ i)))
344           ((or (= i size) (not (whitespacep (char string i))))
345            (and (= i size) (setq index i))))
346       (if (or junk-allow
347               (= index size))
348           (values (* sign value) index)
349           (values nil index)))))
350
351 #+jscl
352 (defun parse-integer (string &key junk-allowed)
353   (multiple-value-bind (num index)
354       (!parse-integer string junk-allowed)
355     (if num
356         (values num index)
357         (error "Junk detected."))))
358
359 (defvar *eof* (gensym))
360 (defun ls-read-1 (stream)
361   (skip-whitespaces-and-comments stream)
362   (let ((ch (%peek-char stream)))
363     (cond
364       ((or (null ch) (char= ch #\)))
365        *eof*)
366       ((char= ch #\()
367        (%read-char stream)
368        (%read-list stream))
369       ((char= ch #\')
370        (%read-char stream)
371        (list 'quote (ls-read-1 stream)))
372       ((char= ch #\`)
373        (%read-char stream)
374        (list 'backquote (ls-read-1 stream)))
375       ((char= ch #\")
376        (%read-char stream)
377        (read-string stream))
378       ((char= ch #\,)
379        (%read-char stream)
380        (if (eql (%peek-char stream) #\@)
381            (progn (%read-char stream) (list 'unquote-splicing (ls-read-1 stream)))
382            (list 'unquote (ls-read-1 stream))))
383       ((char= ch #\#)
384        (read-sharp stream))
385       (t
386        (let ((string (read-escaped-until stream #'terminalp)))
387          (or (read-integer string)
388              (read-float string)
389              (read-symbol string)))))))
390
391 (defun ls-read (stream &optional (eof-error-p t) eof-value)
392   (let ((x (ls-read-1 stream)))
393     (if (eq x *eof*)
394         (if eof-error-p
395             (error "End of file")
396             eof-value)
397         x)))
398
399 (defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
400   (ls-read (make-string-stream string) eof-error-p eof-value))
401
402 #+jscl
403 (defun read-from-string (string &optional (eof-errorp t) eof-value)
404   (ls-read-from-string string eof-errorp eof-value))