3 ;; Copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
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.
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.
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/>.
22 ;;; The Lisp reader, parse strings and return Lisp objects. The main
23 ;;; entry points are `ls-read' and `ls-read-from-string'.
25 ;;; #= / ## implementation
27 ;; For now associations label->object are kept in a plist
28 ;; May be it makes sense to use a vector instead if speed
29 ;; is considered a problem with many labelled objects
30 (defvar *labelled-objects* nil)
32 (defun new-labelled-objects-table ()
33 (setf *labelled-objects* nil))
35 (defun find-labelled-object (id)
36 (assoc id *labelled-objects*))
38 (defun add-labelled-object (id value)
39 (push (cons id value) *labelled-objects*))
41 ;; A unique value used to mark in the labelled objects
42 ;; table an object that is being constructed
43 ;; (e.g. #1# while reading elements of "#1=(#1# #1# #1#)")
44 (defvar *future-value* (make-symbol "future"))
46 ;; A unique value used to mark temporary values that will
47 ;; be replaced when fixups are run.
48 (defvar *fixup-value* (make-symbol "fixup"))
50 ;; Fixup locations keeps a list of conses where the CAR
51 ;; is a callable to be called with the value of the object
52 ;; associated to label stored in CDR once reading is completed
53 (defvar *fixup-locations* nil)
55 (defun fixup-backrefs ()
56 (while *fixup-locations*
57 (let* ((fixup (pop *fixup-locations*))
58 (callable (car fixup))
59 (cell (find-labelled-object (cdr fixup))))
61 (funcall callable (cdr cell))
62 (error "Internal error in fixup-backrefs: object #~S# not found"
65 ;; A function that will need to return a fixup callback
66 ;; for the object that is being read. The returned callback will
67 ;; be called with the result of reading.
68 (defvar *make-fixup-function*
70 (error "Internal error in fixup creation during read")))
72 (defun make-string-stream (string)
75 (defun %peek-char (stream)
76 (and (< (cdr stream) (length (car stream)))
77 (char (car stream) (cdr stream))))
79 (defun %read-char (stream)
80 (and (< (cdr stream) (length (car stream)))
81 (prog1 (char (car stream) (cdr stream))
82 (rplacd stream (1+ (cdr stream))))))
84 (defun whitespacep (ch)
85 (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
87 (defun skip-whitespaces (stream)
89 (setq ch (%peek-char stream))
90 (while (and ch (whitespacep ch))
92 (setq ch (%peek-char stream)))))
95 (or (null ch) (whitespacep ch) (char= #\" ch) (char= #\) ch) (char= #\( ch)))
97 (defun read-until (stream func)
100 (setq ch (%peek-char stream))
101 (while (and ch (not (funcall func ch)))
102 (setq string (concat string (string ch)))
104 (setq ch (%peek-char stream)))
107 (defun read-escaped-until (stream func)
109 (ch (%peek-char stream))
111 (while (and ch (or multi-escape (not (funcall func ch))))
115 (setf multi-escape nil)
116 (setf multi-escape t)))
119 (setf ch (%peek-char stream))
120 (setf string (concat string "\\" (string ch))))
123 (setf string (concat string "\\" (string ch)))
124 (setf string (concat string (string ch))))))
126 (setf ch (%peek-char stream)))
129 (defun skip-whitespaces-and-comments (stream)
131 (skip-whitespaces stream)
132 (setq ch (%peek-char stream))
133 (while (and ch (char= ch #\;))
134 (read-until stream (lambda (x) (char= x #\newline)))
135 (skip-whitespaces stream)
136 (setq ch (%peek-char stream)))))
138 (defun discard-char (stream expected)
139 (let ((ch (%read-char stream)))
141 (error "End of file when character ~S was expected." expected))
142 (unless (char= ch expected)
143 (error "Character ~S was found but ~S was expected." ch expected))))
145 (defun %read-list (stream &optional (eof-error-p t) eof-value)
146 (skip-whitespaces-and-comments stream)
147 (let ((ch (%peek-char stream)))
150 (error "Unspected EOF"))
152 (discard-char stream #\))
155 (let* ((cell (cons nil nil))
156 (*make-fixup-function* (lambda ()
160 (next (ls-read stream nil eof t)))
162 (skip-whitespaces-and-comments stream)
165 (discard-char stream #\))
168 (if (char= (%peek-char stream) #\.)
170 (discard-char stream #\.)
171 (if (terminalp (%peek-char stream))
172 (let ((*make-fixup-function* (lambda ()
174 (rplacd cell obj)))))
175 ;; Dotted pair notation
176 (rplacd cell (ls-read stream eof-error-p eof-value t))
177 (skip-whitespaces-and-comments stream)
178 (let ((ch (%peek-char stream)))
179 (if (or (null ch) (char= #\) ch))
180 (discard-char stream #\))
181 (error "Multiple objects following . in a list"))))
182 (let ((token (concat "." (read-escaped-until stream #'terminalp))))
183 (rplacd cell (cons (interpret-token token)
184 (%read-list stream eof-error-p eof-value))))))
185 (rplacd cell (%read-list stream eof-error-p eof-value)))
188 (defun read-string (stream)
191 (setq ch (%read-char stream))
192 (while (not (eql ch #\"))
194 (error "Unexpected EOF"))
196 (setq ch (%read-char stream)))
197 (setq string (concat string (string ch)))
198 (setq ch (%read-char stream)))
201 (defun read-sharp (stream &optional eof-error-p eof-value)
203 (let ((ch (%read-char stream)))
206 (list 'function (ls-read stream eof-error-p eof-value t)))
210 (index 0 (1+ index)))
211 ((progn (skip-whitespaces-and-comments stream)
212 (or (null (%peek-char stream))
213 (char= (%peek-char stream) #\))))
214 (discard-char stream #\))
215 (setf result (make-array index))
217 (aset result (decf index) (pop elements)))
219 (let* ((ix index) ; Can't just use index: the same var would be captured in all fixups
220 (*make-fixup-function* (lambda ()
222 (aset result ix obj))))
224 (value (ls-read stream nil eof t)))
225 (push value elements))))
229 (string-upcase-noescaped
230 (read-escaped-until stream #'terminalp)))))
233 (concat (string (%read-char stream))
234 (read-until stream #'terminalp))))
236 ((string= cname "space") #\space)
237 ((string= cname "tab") #\tab)
238 ((string= cname "newline") #\newline)
239 (t (char cname 0)))))
241 (let ((feature (let ((symbol (ls-read stream eof-error-p eof-value t)))
242 (unless (symbolp symbol)
243 (error "Invalid feature ~S" symbol))
244 (intern (string symbol) "KEYWORD"))))
245 (if (eql (char= ch #\+)
246 (and (find feature *features*) t))
247 (ls-read stream eof-error-p eof-value t)
248 (prog2 (ls-read stream)
249 (ls-read stream eof-error-p eof-value t)))))
251 (unless (char= (%peek-char stream) #\:)
252 (error "FFI descriptor must start with a semicolon."))
253 (let ((descriptor (subseq (read-until stream #'terminalp) 1))
254 (subdescriptors nil))
255 (do* ((start 0 (1+ end))
256 (end (position #\: descriptor :start start)
257 (position #\: descriptor :start start)))
259 (push (subseq descriptor start) subdescriptors)
260 `(oget *root* ,@(reverse subdescriptors)))
261 (push (subseq descriptor start end) subdescriptors))))
264 ((and ch (digit-char-p ch))
265 (let ((id (digit-char-p ch)))
266 (while (and (%peek-char stream)
267 (digit-char-p (%peek-char stream)))
268 (setf id (+ (* id 10) (digit-char-p (%read-char stream)))))
269 (ecase (%peek-char stream)
272 (if (find-labelled-object id)
273 (error "Duplicated label #~S=" id)
275 (add-labelled-object id *future-value*)
276 (let ((obj (ls-read stream eof-error-p eof-value t)))
277 ;; FIXME: somehow the more natural
278 ;; (setf (cdr (find-labelled-object id)) obj)
280 (rplacd (find-labelled-object id) obj)
284 (let ((cell (find-labelled-object id)))
286 (if (eq (cdr cell) *future-value*)
288 (push (cons (funcall *make-fixup-function*)
293 (error "Invalid labelled object #~S#" id)))))))
295 (error "Invalid dispatch character after #")))))))
297 (defun unescape-token (x)
299 (dotimes (i (length x))
300 (unless (char= (char x i) #\\)
301 (setq result (concat result (string (char x i))))))
304 (defun string-upcase-noescaped (s)
307 (dotimes (i (length s))
308 (let ((ch (char s i)))
311 (setf last-escape nil)
312 (setf result (concat result (string ch))))
315 (setf result (concat result (string-upcase (string ch))))))))
318 ;;; Parse a string of the form NAME, PACKAGE:NAME or
319 ;;; PACKAGE::NAME and return the name. If the string is of the
320 ;;; form 1) or 3), but the symbol does not exist, it will be created
321 ;;; and interned in that package.
322 (defun read-symbol (string)
323 (let ((size (length string))
324 package name internalp index)
326 (while (and (< index size)
327 (not (char= (char string index) #\:)))
328 (when (char= (char string index) #\\)
335 (setq package (package-name *package*))
340 (setq package "KEYWORD")
341 (setq package (string-upcase-noescaped (subseq string 0 index))))
343 (when (char= (char string index) #\:)
346 (setq name (subseq string index))))
347 ;; Canonalize symbol name and package
348 (setq name (if (string= package "JS")
349 (setq name (unescape-token name))
350 (setq name (string-upcase-noescaped name))))
351 (setq package (find-package package))
353 (eq package (find-package "KEYWORD"))
354 (eq package (find-package "JS")))
355 (intern name package)
356 (multiple-value-bind (symbol external)
357 (find-symbol name package)
358 (if (eq external :external)
360 (error "The symbol `~S' is not external in the package ~S." name package))))))
362 (defun read-integer (string)
365 (size (length string)))
367 (let ((elt (char string i)))
370 (setq number (+ (* (or number 0) 10) (digit-char-p elt))))
375 (t (return-from read-integer))))
376 ((and (= i (1- size)) (char= elt #\.)) nil)
377 (t (return-from read-integer)))))
378 (and number (* sign number))))
380 (defun read-float (string)
384 (fractional-part nil)
389 (size (length string))
391 (when (zerop size) (return))
393 (case (char string index)
397 (unless (< index size) (return))
398 ;; Optional integer part
399 (awhen (digit-char-p (char string index))
400 (setq integer-part t)
401 (while (and (< index size)
402 (setq it (digit-char-p (char string index))))
403 (setq number (+ (* number 10) it))
405 (unless (< index size) (return))
406 ;; Decimal point is mandatory if there's no integer part
407 (unless (or integer-part (char= #\. (char string index))) (return))
408 ;; Optional fractional part
409 (when (char= #\. (char string index))
411 (unless (< index size) (return))
412 (awhen (digit-char-p (char string index))
413 (setq fractional-part t)
414 (while (and (< index size)
415 (setq it (digit-char-p (char string index))))
416 (setq number (+ (* number 10) it))
417 (setq divisor (* divisor 10))
419 ;; Either left or right part of the dot must be present
420 (unless (or integer-part fractional-part) (return))
421 ;; Exponent is mandatory if there is no fractional part
422 (when (and (= index size) (not fractional-part)) (return))
423 ;; Optional exponent part
426 (unless (find (char-upcase (char string index)) "ESFDL")
429 (unless (< index size) (return))
430 ;; Optional exponent sign
431 (case (char string index)
433 (#\- (setq exponent-sign -1)
435 (unless (< index size) (return))
437 (let ((value (digit-char-p (char string index))))
438 (unless value (return))
439 (while (and (< index size)
440 (setq value (digit-char-p (char string index))))
441 (setq exponent (+ (* exponent 10) value))
443 (unless (= index size) (return))
444 ;; Everything went ok, we have a float
445 ;; XXX: Use FLOAT when implemented.
446 (/ (* sign (expt 10.0 (* exponent-sign exponent)) number) divisor 1.0))))
448 (defun !parse-integer (string junk-allow)
452 (size (length string))
454 ;; Leading whitespace
455 (while (and (< index size)
456 (whitespacep (char string index)))
458 (unless (< index size) (return (values nil 0)))
460 (case (char string 0)
465 (unless (and (< index size)
466 (setq value (digit-char-p (char string index))))
467 (return (values nil index)))
470 (while (< index size)
471 (let ((digit (digit-char-p (char string index))))
472 (unless digit (return))
473 (setq value (+ (* value 10) digit))
475 ;; Trailing whitespace
476 (do ((i index (1+ i)))
477 ((or (= i size) (not (whitespacep (char string i))))
478 (and (= i size) (setq index i))))
481 (values (* sign value) index)
482 (values nil index)))))
485 (defun parse-integer (string &key junk-allowed)
486 (multiple-value-bind (num index)
487 (!parse-integer string junk-allowed)
490 (error "Junk detected."))))
493 (defun interpret-token (string)
494 (or (read-integer string)
496 (read-symbol string)))
498 (defun ls-read (stream &optional (eof-error-p t) eof-value recursive-p)
499 (let ((save-labelled-objects *labelled-objects*)
500 (save-fixup-locations *fixup-locations*))
502 (setf *fixup-locations* nil)
503 (setf *labelled-objects* (new-labelled-objects-table)))
506 (skip-whitespaces-and-comments stream)
507 (let ((ch (%peek-char stream)))
509 ((or (null ch) (char= ch #\)))
511 (error "End of file")
515 (%read-list stream eof-error-p eof-value))
518 (list 'quote (ls-read stream eof-error-p eof-value t)))
521 (list 'backquote (ls-read stream eof-error-p eof-value t)))
524 (read-string stream))
527 (if (eql (%peek-char stream) #\@)
528 (progn (%read-char stream) (list 'unquote-splicing
529 (ls-read stream eof-error-p eof-value t)))
530 (list 'unquote (ls-read stream eof-error-p eof-value t))))
532 (read-sharp stream eof-error-p eof-value))
534 (let ((string (read-escaped-until stream #'terminalp)))
535 (interpret-token string))))))
538 (setf *labelled-objects* save-labelled-objects)
539 (setf *fixup-locations* save-fixup-locations)))))
541 (defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
542 (ls-read (make-string-stream string) eof-error-p eof-value))
545 (defun read-from-string (string &optional (eof-errorp t) eof-value)
546 (ls-read-from-string string eof-errorp eof-value))