Add *version* variable
[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 (/debug "loading read.lisp!")
20
21 ;;;; Reader
22
23 ;;; The Lisp reader, parse strings and return Lisp objects. The main
24 ;;; entry points are `ls-read' and `ls-read-from-string'.
25
26 ;;; #= / ## implementation
27
28 ;; For now associations label->object are kept in a plist
29 ;; May be it makes sense to use a vector instead if speed
30 ;; is considered a problem with many labelled objects
31 (defvar *labelled-objects* nil)
32
33 (defun new-labelled-objects-table ()
34   (setf *labelled-objects* nil))
35
36 (defun find-labelled-object (id)
37   (assoc id *labelled-objects*))
38
39 (defun add-labelled-object (id value)
40   (push (cons id value) *labelled-objects*))
41
42 ;; A unique value used to mark in the labelled objects
43 ;; table an object that is being constructed
44 ;; (e.g. #1# while reading elements of "#1=(#1# #1# #1#)")
45 (defvar *future-value* (make-symbol "future"))
46
47 ;; A unique value used to mark temporary values that will
48 ;; be replaced when fixups are run.
49 (defvar *fixup-value* (make-symbol "fixup"))
50
51 ;; Fixup locations keeps a list of conses where the CAR
52 ;; is a callable to be called with the value of the object
53 ;; associated to label stored in CDR once reading is completed
54 (defvar *fixup-locations* nil)
55
56 (defun fixup-backrefs ()
57   (while *fixup-locations*
58     (let* ((fixup (pop *fixup-locations*))
59            (callable (car fixup))
60            (cell (find-labelled-object (cdr fixup))))
61       (if cell
62           (funcall callable (cdr cell))
63           (error "Internal error in fixup-backrefs: object #~S# not found"
64                  (cdr fixup))))))
65
66 ;; A function that will need to return a fixup callback
67 ;; for the object that is being read. The returned callback will
68 ;; be called with the result of reading.
69 (defvar *make-fixup-function*
70   (lambda ()
71     (error "Internal error in fixup creation during read")))
72
73 (defun make-string-stream (string)
74   (cons string 0))
75
76 (defun %peek-char (stream)
77   (and (< (cdr stream) (length (car stream)))
78        (char (car stream) (cdr stream))))
79
80 (defun %read-char (stream)
81   (and (< (cdr stream) (length (car stream)))
82        (prog1 (char (car stream) (cdr stream))
83          (rplacd stream (1+ (cdr stream))))))
84
85 (defun whitespacep (ch)
86   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
87
88 (defun skip-whitespaces (stream)
89   (let (ch)
90     (setq ch (%peek-char stream))
91     (while (and ch (whitespacep ch))
92       (%read-char stream)
93       (setq ch (%peek-char stream)))))
94
95 (defun terminalp (ch)
96   (or (null ch) (whitespacep ch) (char= #\" ch) (char= #\) ch) (char= #\( ch)))
97
98 (defun read-until (stream func)
99   (let ((string "")
100         (ch))
101     (setq ch (%peek-char stream))
102     (while (and ch (not (funcall func ch)))
103       (setq string (concat string (string ch)))
104       (%read-char stream)
105       (setq ch (%peek-char stream)))
106     string))
107
108 (defun read-escaped-until (stream func)
109   (let ((string "")
110         (ch (%peek-char stream))
111         (multi-escape nil))
112     (while (and ch (or multi-escape (not (funcall func ch))))
113       (cond
114         ((char= ch #\|)
115          (if multi-escape
116              (setf multi-escape nil)
117              (setf multi-escape t)))
118         ((char= ch #\\)
119          (%read-char stream)
120          (setf ch (%peek-char stream))
121          (setf string (concat string "\\" (string ch))))
122         (t
123          (if multi-escape
124              (setf string (concat string "\\" (string ch)))
125              (setf string (concat string (string ch))))))
126       (%read-char stream)
127       (setf ch (%peek-char stream)))
128     string))
129
130 (defun skip-whitespaces-and-comments (stream)
131   (let (ch)
132     (skip-whitespaces stream)
133     (setq ch (%peek-char stream))
134     (while (and ch (char= ch #\;))
135       (read-until stream (lambda (x) (char= x #\newline)))
136       (skip-whitespaces stream)
137       (setq ch (%peek-char stream)))))
138
139 (defun discard-char (stream expected)
140   (let ((ch (%read-char stream)))
141     (when (null ch)
142       (error "End of file when character ~S was expected." expected))
143     (unless (char= ch expected)
144       (error "Character ~S was found but ~S was expected." ch expected))))
145
146 (defun %read-list (stream &optional (eof-error-p t) eof-value)
147   (skip-whitespaces-and-comments stream)
148   (let ((ch (%peek-char stream)))
149     (cond
150       ((null ch)
151        (error "Unspected EOF"))
152       ((char= ch #\))
153        (discard-char stream #\))
154        nil)
155       (t
156        (let* ((cell (cons nil nil))
157               (*make-fixup-function* (lambda ()
158                                        (lambda (obj)
159                                          (rplaca cell obj))))
160               (eof (gensym))
161               (next (ls-read stream nil eof t)))
162          (rplaca cell next)
163          (skip-whitespaces-and-comments stream)
164          (cond
165            ((eq next eof)
166             (discard-char stream #\))
167             nil)
168            (t
169             (if (char= (%peek-char stream) #\.)
170                 (progn
171                   (discard-char stream #\.)
172                   (if (terminalp (%peek-char stream))
173                       (let ((*make-fixup-function* (lambda ()
174                                                      (lambda (obj)
175                                                        (rplacd cell obj)))))
176                         ;; Dotted pair notation
177                         (rplacd cell (ls-read stream eof-error-p eof-value t))
178                         (skip-whitespaces-and-comments stream)
179                         (let ((ch (%peek-char stream)))
180                           (if (or (null ch) (char= #\) ch))
181                               (discard-char stream #\))
182                               (error "Multiple objects following . in a list"))))
183                       (let ((token (concat "." (read-escaped-until stream #'terminalp))))
184                         (rplacd cell (cons (interpret-token token)
185                                            (%read-list stream eof-error-p eof-value))))))
186                 (rplacd cell (%read-list stream eof-error-p eof-value)))
187             cell)))))))
188
189 (defun read-string (stream)
190   (let ((string "")
191         (ch nil))
192     (setq ch (%read-char stream))
193     (while (not (eql ch #\"))
194       (when (null ch)
195         (error "Unexpected EOF"))
196       (when (eql ch #\\)
197         (setq ch (%read-char stream)))
198       (setq string (concat string (string ch)))
199       (setq ch (%read-char stream)))
200     string))
201
202 (defun read-sharp (stream &optional eof-error-p eof-value)
203   (%read-char stream)
204   (let ((ch (%read-char stream)))
205     (case ch
206       (#\'
207        (list 'function (ls-read stream eof-error-p eof-value t)))
208       (#\(
209        (do ((elements nil)
210             (result nil)
211             (index 0 (1+ index)))
212            ((progn (skip-whitespaces-and-comments stream)
213                    (or (null (%peek-char stream))
214                        (char= (%peek-char stream) #\))))
215             (discard-char stream #\))
216             (setf result (make-array index))
217             (dotimes (i index)
218               (aset result (decf index) (pop elements)))
219             result)
220          (let* ((ix index) ; Can't just use index: the same var would be captured in all fixups
221                 (*make-fixup-function* (lambda ()
222                                          (lambda (obj)
223                                            (aset result ix obj))))
224                 (eof (gensym))
225                 (value (ls-read stream nil eof t)))
226            (push value elements))))
227       (#\:
228        (make-symbol
229         (unescape-token
230          (string-upcase-noescaped
231           (read-escaped-until stream #'terminalp)))))
232       (#\\
233        (let ((cname
234               (concat (string (%read-char stream))
235                       (read-until stream #'terminalp))))
236          (cond
237            ((string= cname "space") #\space)
238            ((string= cname "tab") #\tab)
239            ((string= cname "newline") #\newline)
240            (t (char cname 0)))))
241       ((#\+ #\-)
242        (let ((feature (let ((symbol (ls-read stream eof-error-p eof-value t)))
243                         (unless (symbolp symbol)
244                           (error "Invalid feature ~S" symbol))
245                         (intern (string symbol) "KEYWORD"))))
246          (if (eql (char= ch #\+)
247                   (and (find feature *features*) t))
248              (ls-read stream eof-error-p eof-value t)
249              (prog2 (ls-read stream)
250                  (ls-read stream eof-error-p eof-value t)))))
251       ((#\J #\j)
252        (unless (char= (%peek-char stream) #\:)
253          (error "FFI descriptor must start with a semicolon."))
254        (let ((descriptor (subseq (read-until stream #'terminalp) 1))
255              (subdescriptors nil))
256          (do* ((start 0 (1+ end))
257                (end (position #\: descriptor :start start)
258                     (position #\: descriptor :start start)))
259               ((null end)
260                (push (subseq descriptor start) subdescriptors)
261                `(oget *root* ,@(reverse subdescriptors)))
262            (push (subseq descriptor start end) subdescriptors))))
263       (otherwise
264        (cond
265          ((and ch (digit-char-p ch))
266           (let ((id (digit-char-p ch)))
267             (while (and (%peek-char stream)
268                         (digit-char-p (%peek-char stream)))
269               (setf id (+ (* id 10) (digit-char-p (%read-char stream)))))
270             (ecase (%peek-char stream)
271               (#\=
272                (%read-char stream)
273                (if (find-labelled-object id)
274                    (error "Duplicated label #~S=" id)
275                    (progn
276                      (add-labelled-object id *future-value*)
277                      (let ((obj (ls-read stream eof-error-p eof-value t)))
278                        ;; FIXME: somehow the more natural
279                        ;;    (setf (cdr (find-labelled-object id)) obj)
280                        ;; doesn't work
281                        (rplacd (find-labelled-object id) obj)
282                        obj))))
283               (#\#
284                (%read-char stream)
285                (let ((cell (find-labelled-object id)))
286                  (if cell
287                      (if (eq (cdr cell) *future-value*)
288                          (progn
289                            (push (cons (funcall *make-fixup-function*)
290                                        id)
291                                  *fixup-locations*)
292                            *fixup-value*)
293                          (cdr cell))
294                      (error "Invalid labelled object #~S#" id)))))))
295          (t
296           (error "Invalid dispatch character after #")))))))
297
298 (defun unescape-token (x)
299   (let ((result ""))
300     (dotimes (i (length x))
301       (unless (char= (char x i) #\\)
302         (setq result (concat result (string (char x i))))))
303     result))
304
305 (defun string-upcase-noescaped (s)
306   (let ((result "")
307         (last-escape nil))
308     (dotimes (i (length s))
309       (let ((ch (char s i)))
310         (if last-escape
311            (progn
312               (setf last-escape nil)
313               (setf result (concat result (string ch))))
314             (if (char= ch #\\)
315                 (setf last-escape t)
316                 (setf result (concat result (string-upcase (string ch))))))))
317     result))
318
319 ;;; Parse a string of the form NAME, PACKAGE:NAME or
320 ;;; PACKAGE::NAME and return the name. If the string is of the
321 ;;; form 1) or 3), but the symbol does not exist, it will be created
322 ;;; and interned in that package.
323 (defun read-symbol (string)
324   (let ((size (length string))
325         package name internalp index)
326     (setq index 0)
327     (while (and (< index size)
328                 (not (char= (char string index) #\:)))
329       (when (char= (char string index) #\\)
330         (incf index))
331       (incf index))
332     (cond
333       ;; No package prefix
334       ((= index size)
335        (setq name string)
336        (setq package (package-name *package*))
337        (setq internalp t))
338       (t
339        ;; Package prefix
340        (if (zerop index)
341            (setq package "KEYWORD")
342            (setq package (string-upcase-noescaped (subseq string 0 index))))
343        (incf index)
344        (when (char= (char string index) #\:)
345          (setq internalp t)
346          (incf index))
347        (setq name (subseq string index))))
348     ;; Canonalize symbol name and package
349     (setq name (if (string= package "JS")
350                    (setq name (unescape-token name))
351                    (setq name (string-upcase-noescaped name))))
352     (setq package (find-package package))
353     (if (or internalp
354             (eq package (find-package "KEYWORD"))
355             (eq package (find-package "JS")))
356         (intern name package)
357         (multiple-value-bind (symbol external)
358             (find-symbol name package)
359           (if (eq external :external)
360               symbol
361               (error "The symbol `~S' is not external in the package ~S." name package))))))
362
363 (defun read-integer (string)
364   (let ((sign 1)
365         (number nil)
366         (size (length string)))
367     (dotimes (i size)
368       (let ((elt (char string i)))
369         (cond
370           ((digit-char-p elt)
371            (setq number (+ (* (or number 0) 10) (digit-char-p elt))))
372           ((zerop i)
373            (case elt
374              (#\+ nil)
375              (#\- (setq sign -1))
376              (t (return-from read-integer))))
377           ((and (= i (1- size)) (char= elt #\.)) nil)
378           (t (return-from read-integer)))))
379     (and number (* sign number))))
380
381 (defun read-float (string)
382   (block nil
383     (let ((sign 1)
384           (integer-part nil)
385           (fractional-part nil)
386           (number 0)
387           (divisor 1)
388           (exponent-sign 1)
389           (exponent 0)
390           (size (length string))
391           (index 0))
392       (when (zerop size) (return))
393       ;; Optional sign
394       (case (char string index)
395         (#\+ (incf index))
396         (#\- (setq sign -1)
397              (incf index)))
398       (unless (< index size) (return))
399       ;; Optional integer part
400       (awhen (digit-char-p (char string index))
401         (setq integer-part t)
402         (while (and (< index size)
403                     (setq it (digit-char-p (char string index))))
404           (setq number (+ (* number 10) it))
405           (incf index)))
406       (unless (< index size) (return))
407       ;; Decimal point is mandatory if there's no integer part
408       (unless (or integer-part (char= #\. (char string index))) (return))
409       ;; Optional fractional part
410       (when (char= #\. (char string index))
411         (incf index)
412         (unless (< index size) (return))
413         (awhen (digit-char-p (char string index))
414           (setq fractional-part t)
415           (while (and (< index size)
416                       (setq it (digit-char-p (char string index))))
417             (setq number (+ (* number 10) it))
418             (setq divisor (* divisor 10))
419             (incf index))))
420       ;; Either left or right part of the dot must be present
421       (unless (or integer-part fractional-part) (return))
422       ;; Exponent is mandatory if there is no fractional part
423       (when (and (= index size) (not fractional-part)) (return))
424       ;; Optional exponent part
425       (when (< index size)
426         ;; Exponent-marker
427         (unless (find (char-upcase (char string index)) "ESFDL")
428           (return))
429         (incf index)
430         (unless (< index size) (return))
431         ;; Optional exponent sign
432         (case (char string index)
433           (#\+ (incf index))
434           (#\- (setq exponent-sign -1)
435                (incf index)))
436         (unless (< index size) (return))
437         ;; Exponent digits
438         (let ((value (digit-char-p (char string index))))
439           (unless value (return))
440           (while (and (< index size)
441                       (setq value (digit-char-p (char string index))))
442             (setq exponent (+ (* exponent 10) value))
443             (incf index))))
444       (unless (= index size) (return))
445       ;; Everything went ok, we have a float
446       ;; XXX: Use FLOAT when implemented.
447       (/ (* sign (expt 10.0 (* exponent-sign exponent)) number) divisor 1.0))))
448
449 (defun !parse-integer (string junk-allow)
450   (block nil
451     (let ((value 0)
452           (index 0)
453           (size (length string))
454           (sign 1))
455       ;; Leading whitespace
456       (while (and (< index size)
457                   (whitespacep (char string index)))
458         (incf index))
459       (unless (< index size) (return (values nil 0)))
460       ;; Optional sign
461       (case (char string 0)
462         (#\+ (incf index))
463         (#\- (setq sign -1)
464              (incf index)))
465       ;; First digit
466       (unless (and (< index size)
467                    (setq value (digit-char-p (char string index))))
468         (return (values nil index)))
469       (incf index)
470       ;; Other digits
471       (while (< index size)
472         (let ((digit (digit-char-p (char string index))))
473           (unless digit (return))
474           (setq value (+ (* value 10) digit))
475           (incf index)))
476       ;; Trailing whitespace
477       (do ((i index (1+ i)))
478           ((or (= i size) (not (whitespacep (char string i))))
479            (and (= i size) (setq index i))))
480       (if (or junk-allow
481               (= index size))
482           (values (* sign value) index)
483           (values nil index)))))
484
485 #+jscl
486 (defun parse-integer (string &key junk-allowed)
487   (multiple-value-bind (num index)
488       (!parse-integer string junk-allowed)
489     (if num
490         (values num index)
491         (error "Junk detected."))))
492
493
494 (defun interpret-token (string)
495   (or (read-integer string)
496       (read-float string)
497       (read-symbol string)))
498
499 (defun ls-read (stream &optional (eof-error-p t) eof-value recursive-p)
500   (let ((save-labelled-objects *labelled-objects*)
501         (save-fixup-locations *fixup-locations*))
502     (unless recursive-p
503       (setf *fixup-locations* nil)
504       (setf *labelled-objects* (new-labelled-objects-table)))
505     (prog1
506         (progn
507           (skip-whitespaces-and-comments stream)
508           (let ((ch (%peek-char stream)))
509             (cond
510               ((or (null ch) (char= ch #\)))
511                (if eof-error-p
512                    (error "End of file")
513                    eof-value))
514               ((char= ch #\()
515                (%read-char stream)
516                (%read-list stream eof-error-p eof-value))
517               ((char= ch #\')
518                (%read-char stream)
519                (list 'quote (ls-read stream eof-error-p eof-value t)))
520               ((char= ch #\`)
521                (%read-char stream)
522                (list 'backquote (ls-read stream eof-error-p eof-value t)))
523               ((char= ch #\")
524                (%read-char stream)
525                (read-string stream))
526               ((char= ch #\,)
527                (%read-char stream)
528                (if (eql (%peek-char stream) #\@)
529                    (progn (%read-char stream) (list 'unquote-splicing
530                                                     (ls-read stream eof-error-p eof-value t)))
531                    (list 'unquote (ls-read stream eof-error-p eof-value t))))
532               ((char= ch #\#)
533                (read-sharp stream eof-error-p eof-value))
534               (t
535                (let ((string (read-escaped-until stream #'terminalp)))
536                  (interpret-token string))))))
537       (unless recursive-p
538         (fixup-backrefs)
539         (setf *labelled-objects* save-labelled-objects)
540         (setf *fixup-locations* save-fixup-locations)))))
541
542 (defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
543   (ls-read (make-string-stream string) eof-error-p eof-value))
544
545 #+jscl
546 (defun read-from-string (string &optional (eof-errorp t) eof-value)
547   (ls-read-from-string string eof-errorp eof-value))