c99604a81757f86551bc6b1f7417f01dd7045c4d
[jscl.git] / src / read.lisp
1 ;;; read.lisp --- 
2
3 ;; Copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
5
6 ;; This program 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 ;; This program 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 this program.  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 skip-whitespaces-and-comments (stream)
61   (let (ch)
62     (skip-whitespaces stream)
63     (setq ch (%peek-char stream))
64     (while (and ch (char= ch #\;))
65       (read-until stream (lambda (x) (char= x #\newline)))
66       (skip-whitespaces stream)
67       (setq ch (%peek-char stream)))))
68
69 (defun %read-list (stream)
70   (skip-whitespaces-and-comments stream)
71   (let ((ch (%peek-char stream)))
72     (cond
73       ((null ch)
74        (error "Unspected EOF"))
75       ((char= ch #\))
76        (%read-char stream)
77        nil)
78       ((char= ch #\.)
79        (%read-char stream)
80        (prog1 (ls-read-1 stream)
81          (skip-whitespaces-and-comments stream)
82          (unless (char= (%read-char stream) #\))
83            (error "')' was expected."))))
84       (t
85        (cons (ls-read-1 stream) (%read-list stream))))))
86
87 (defun read-string (stream)
88   (let ((string "")
89         (ch nil))
90     (setq ch (%read-char stream))
91     (while (not (eql ch #\"))
92       (when (null ch)
93         (error "Unexpected EOF"))
94       (when (eql ch #\\)
95         (setq ch (%read-char stream)))
96       (setq string (concat string (string ch)))
97       (setq ch (%read-char stream)))
98     string))
99
100 (defun read-sharp (stream)
101   (%read-char stream)
102   (ecase (%read-char stream)
103     (#\'
104      (list 'function (ls-read-1 stream)))
105     (#\( (list-to-vector (%read-list stream)))
106     (#\: (make-symbol (string-upcase (read-until stream #'terminalp))))
107     (#\\
108      (let ((cname
109             (concat (string (%read-char stream))
110                     (read-until stream #'terminalp))))
111        (cond
112          ((string= cname "space") (char-code #\space))
113          ((string= cname "tab") (char-code #\tab))
114          ((string= cname "newline") (char-code #\newline))
115          (t (char-code (char cname 0))))))
116     (#\+
117      (let ((feature (read-until stream #'terminalp)))
118        (cond
119          ((string= feature "common-lisp")
120           (ls-read-1 stream)              ;ignore
121           (ls-read-1 stream))
122          ((string= feature "jscl")
123           (ls-read-1 stream))
124          (t
125           (error "Unknown reader form.")))))))
126
127 ;;; Parse a string of the form NAME, PACKAGE:NAME or
128 ;;; PACKAGE::NAME and return the name. If the string is of the
129 ;;; form 1) or 3), but the symbol does not exist, it will be created
130 ;;; and interned in that package.
131 (defun read-symbol (string)
132   (let ((size (length string))
133         package name internalp index)
134     (setq index 0)
135     (while (and (< index size)
136                 (not (char= (char string index) #\:)))
137       (incf index))
138     (cond
139       ;; No package prefix
140       ((= index size)
141        (setq name string)
142        (setq package *package*)
143        (setq internalp t))
144       (t
145        ;; Package prefix
146        (if (zerop index)
147            (setq package "KEYWORD")
148            (setq package (string-upcase (subseq string 0 index))))
149        (incf index)
150        (when (char= (char string index) #\:)
151          (setq internalp t)
152          (incf index))
153        (setq name (subseq string index))))
154     ;; Canonalize symbol name and package
155     (when (not (eq package "JS"))
156       (setq name (string-upcase name)))
157     (setq package (find-package package))
158     ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an
159     ;; external symbol from PACKAGE.
160     (if (or internalp
161             (eq package (find-package "KEYWORD"))
162             (eq package (find-package "JS")))
163         (intern name package)
164         (find-symbol name package))))
165
166 (defun read-float (string)
167   (block nil
168     (let ((sign 1)
169           (integer-part nil)
170           (fractional-part nil)
171           (number 0)
172           (divisor 1)
173           (exponent-sign 1)
174           (exponent 0)
175           (size (length string))
176           (index 0))
177       (when (zerop size) (return))
178       ;; Optional sign
179       (case (char string index)
180         (#\+ (incf index))
181         (#\- (setq sign -1)
182              (incf index)))
183       (unless (< index size) (return))
184       ;; Optional integer part
185       (awhen (digit-char-p (char string index))
186         (setq integer-part t)
187         (while (and (< index size)
188                     (setq it (digit-char-p (char string index))))
189           (setq number (+ (* number 10) it))
190           (incf index)))
191       (unless (< index size) (return))
192       ;; Decimal point is mandatory if there's no integer part
193       (unless (or integer-part (char= #\. (char string index))) (return))
194       ;; Optional fractional part
195       (when (char= #\. (char string index))
196         (incf index)
197         (unless (< index size) (return))
198         (awhen (digit-char-p (char string index))
199           (setq fractional-part t)
200           (while (and (< index size)
201                       (setq it (digit-char-p (char string index))))
202             (setq number (+ (* number 10) it))
203             (setq divisor (* divisor 10))
204             (incf index))))
205       ;; Either left or right part of the dot must be present
206       (unless (or integer-part fractional-part) (return))
207       ;; Exponent is mandatory if there is no fractional part
208       (when (and (= index size) (not fractional-part)) (return))
209       ;; Optional exponent part
210       (when (< index size)
211         ;; Exponent-marker
212         (unless (member (string-upcase (string (char string index)))
213                         '("E" "S" "F" "D" "L"))
214           (return))
215         (incf index)
216         (unless (< index size) (return))
217         ;; Optional exponent sign
218         (case (char string index)
219           (#\+ (incf index))
220           (#\- (setq exponent-sign -1)
221                (incf index)))
222         (unless (< index size) (return))
223         ;; Exponent digits
224         (let ((value (digit-char-p (char string index))))
225           (unless value (return))
226           (while (and (< index size)
227                       (setq value (digit-char-p (char string index))))
228             (setq exponent (+ (* exponent 10) value))
229             (incf index))))
230       (unless (= index size) (return))
231       ;; Everything went ok, we have a float
232       (/ (* sign (expt 10 (* exponent-sign exponent)) number) divisor))))
233
234
235 (defun !parse-integer (string junk-allow)
236   (block nil
237     (let ((value 0)
238           (index 0)
239           (size (length string))
240           (sign 1))
241       ;; Leading whitespace
242       (while (and (< index size)
243                   (whitespacep (char string index)))
244         (incf index))
245       (unless (< index size) (return (values nil 0)))
246       ;; Optional sign
247       (case (char string 0)
248         (#\+ (incf index))
249         (#\- (setq sign -1)
250              (incf index)))
251       ;; First digit
252       (unless (and (< index size)
253                    (setq value (digit-char-p (char string index))))
254         (return (values nil index)))
255       (incf index)
256       ;; Other digits
257       (while (< index size)
258         (let ((digit (digit-char-p (char string index))))
259           (unless digit (return))
260           (setq value (+ (* value 10) digit))
261           (incf index)))
262       ;; Trailing whitespace
263       (do ((i index (1+ i)))
264           ((or (= i size) (not (whitespacep (char string i))))
265            (and (= i size) (setq index i))))
266       (if (or junk-allow
267               (= index size))
268           (values (* sign value) index)
269           (values nil index)))))
270
271 #+jscl
272 (defun parse-integer (string &key junk-allowed)
273   (multiple-value-bind (num index)
274       (!parse-integer string junk-allowed)
275     (when num
276       (values num index)
277       (error "junk detected."))))
278
279 (defvar *eof* (gensym))
280 (defun ls-read-1 (stream)
281   (skip-whitespaces-and-comments stream)
282   (let ((ch (%peek-char stream)))
283     (cond
284       ((or (null ch) (char= ch #\)))
285        *eof*)
286       ((char= ch #\()
287        (%read-char stream)
288        (%read-list stream))
289       ((char= ch #\')
290        (%read-char stream)
291        (list 'quote (ls-read-1 stream)))
292       ((char= ch #\`)
293        (%read-char stream)
294        (list 'backquote (ls-read-1 stream)))
295       ((char= ch #\")
296        (%read-char stream)
297        (read-string stream))
298       ((char= ch #\,)
299        (%read-char stream)
300        (if (eql (%peek-char stream) #\@)
301            (progn (%read-char stream) (list 'unquote-splicing (ls-read-1 stream)))
302            (list 'unquote (ls-read-1 stream))))
303       ((char= ch #\#)
304        (read-sharp stream))
305       (t
306        (let ((string (read-until stream #'terminalp)))
307          (or (values (!parse-integer string nil))
308              (read-float string)
309              (read-symbol string)))))))
310
311 (defun ls-read (stream &optional (eof-error-p t) eof-value)
312   (let ((x (ls-read-1 stream)))
313     (if (eq x *eof*)
314         (if eof-error-p (error "EOF") eof-value)
315         x)))
316
317 (defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
318   (ls-read (make-string-stream string) eof-error-p eof-value))
319
320 #+jscl
321 (defun read-from-string (string &optional (eof-errorp t) eof-value)
322   (ls-read-from-string string eof-errorp eof-value))