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 (defun make-string-stream (string)
28 (defun %peek-char (stream)
29 (and (< (cdr stream) (length (car stream)))
30 (char (car stream) (cdr stream))))
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))))))
37 (defun whitespacep (ch)
38 (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
40 (defun skip-whitespaces (stream)
42 (setq ch (%peek-char stream))
43 (while (and ch (whitespacep ch))
45 (setq ch (%peek-char stream)))))
48 (or (null ch) (whitespacep ch) (char= #\" ch) (char= #\) ch) (char= #\( ch)))
50 (defun read-until (stream func)
53 (setq ch (%peek-char stream))
54 (while (and ch (not (funcall func ch)))
55 (setq string (concat string (string ch)))
57 (setq ch (%peek-char stream)))
60 (defun read-escaped-until (stream func)
62 (ch (%peek-char stream))
64 (while (and ch (or multi-escape (not (funcall func ch))))
68 (setf multi-escape nil)
69 (setf multi-escape t)))
72 (setf ch (%peek-char stream))
73 (setf string (concat string "\\" (string ch))))
76 (setf string (concat string "\\" (string ch)))
77 (setf string (concat string (string ch))))))
79 (setf ch (%peek-char stream)))
82 (defun skip-whitespaces-and-comments (stream)
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)))))
91 (defun discard-char (stream expected)
92 (let ((ch (%read-char stream)))
94 (error "End of file when character ~S was expected." expected))
95 (unless (char= ch expected)
96 (error "Character ~S was found but ~S was expected." ch expected))))
98 (defun %read-list (stream)
99 (skip-whitespaces-and-comments stream)
100 (let ((ch (%peek-char stream)))
103 (error "Unspected EOF"))
105 (discard-char stream #\))
108 (let* ((eof (gensym))
109 (next (ls-read stream nil eof)))
110 (skip-whitespaces-and-comments stream)
113 (discard-char stream #\)))
116 (if (char= (%peek-char stream) #\.)
118 (discard-char stream #\.)
119 (if (terminalp (%peek-char stream))
120 (prog1 (ls-read stream) ; Dotted pair notation
121 (skip-whitespaces-and-comments stream)
122 (let ((ch (%peek-char stream)))
123 (if (or (null ch) (char= #\) ch))
124 (discard-char stream #\))
125 (error "Multiple objects following . in a list"))))
126 (let ((token (concat "." (read-escaped-until stream #'terminalp))))
127 (cons (interpret-token token)
128 (%read-list stream)))))
129 (%read-list stream))))))))))
131 (defun read-string (stream)
134 (setq ch (%read-char stream))
135 (while (not (eql ch #\"))
137 (error "Unexpected EOF"))
139 (setq ch (%read-char stream)))
140 (setq string (concat string (string ch)))
141 (setq ch (%read-char stream)))
144 (defun read-sharp (stream &optional eof-error-p eof-value)
146 (ecase (%read-char stream)
148 (list 'function (ls-read stream)))
149 (#\( (list-to-vector (%read-list stream)))
152 (string-upcase-noescaped
153 (read-escaped-until stream #'terminalp)))))
156 (concat (string (%read-char stream))
157 (read-until stream #'terminalp))))
159 ((string= cname "space") #\space)
160 ((string= cname "tab") #\tab)
161 ((string= cname "newline") #\newline)
162 (t (char cname 0)))))
164 (let ((feature (let ((symbol (ls-read stream)))
165 (unless (symbolp symbol)
166 (error "Invalid feature ~S" symbol))
167 (intern (string symbol) "KEYWORD"))))
171 (ls-read stream eof-error-p eof-value))
173 (ls-read stream eof-error-p eof-value))
176 (ls-read stream eof-error-p eof-value)))))))
178 (defun unescape-token (x)
180 (dotimes (i (length x))
181 (unless (char= (char x i) #\\)
182 (setq result (concat result (string (char x i))))))
185 (defun string-upcase-noescaped (s)
188 (dotimes (i (length s))
189 (let ((ch (char s i)))
192 (setf last-escape nil)
193 (setf result (concat result (string ch))))
196 (setf result (concat result (string-upcase (string ch))))))))
199 ;;; Parse a string of the form NAME, PACKAGE:NAME or
200 ;;; PACKAGE::NAME and return the name. If the string is of the
201 ;;; form 1) or 3), but the symbol does not exist, it will be created
202 ;;; and interned in that package.
203 (defun read-symbol (string)
204 (let ((size (length string))
205 package name internalp index)
207 (while (and (< index size)
208 (not (char= (char string index) #\:)))
209 (when (char= (char string index) #\\)
216 (setq package *package*)
221 (setq package "KEYWORD")
222 (setq package (string-upcase-noescaped (subseq string 0 index))))
224 (when (char= (char string index) #\:)
227 (setq name (subseq string index))))
228 ;; Canonalize symbol name and package
229 (setq name (if (equal package "JS")
230 (setq name (unescape-token name))
231 (setq name (string-upcase-noescaped name))))
232 (setq package (find-package package))
234 (eq package (find-package "KEYWORD"))
235 (eq package (find-package "JS")))
236 (intern name package)
237 (multiple-value-bind (symbol external)
238 (find-symbol name package)
239 (if (eq external :external)
241 (error "The symbol `~S' is not external in the package ~S." name package))))))
243 (defun read-integer (string)
246 (size (length string)))
248 (let ((elt (char string i)))
251 (setq number (+ (* (or number 0) 10) (digit-char-p elt))))
256 (t (return-from read-integer))))
257 ((and (= i (1- size)) (char= elt #\.)) nil)
258 (t (return-from read-integer)))))
259 (and number (* sign number))))
261 (defun read-float (string)
265 (fractional-part nil)
270 (size (length string))
272 (when (zerop size) (return))
274 (case (char string index)
278 (unless (< index size) (return))
279 ;; Optional integer part
280 (awhen (digit-char-p (char string index))
281 (setq integer-part t)
282 (while (and (< index size)
283 (setq it (digit-char-p (char string index))))
284 (setq number (+ (* number 10) it))
286 (unless (< index size) (return))
287 ;; Decimal point is mandatory if there's no integer part
288 (unless (or integer-part (char= #\. (char string index))) (return))
289 ;; Optional fractional part
290 (when (char= #\. (char string index))
292 (unless (< index size) (return))
293 (awhen (digit-char-p (char string index))
294 (setq fractional-part t)
295 (while (and (< index size)
296 (setq it (digit-char-p (char string index))))
297 (setq number (+ (* number 10) it))
298 (setq divisor (* divisor 10))
300 ;; Either left or right part of the dot must be present
301 (unless (or integer-part fractional-part) (return))
302 ;; Exponent is mandatory if there is no fractional part
303 (when (and (= index size) (not fractional-part)) (return))
304 ;; Optional exponent part
307 (unless (find (char-upcase (char string index)) "ESFDL")
310 (unless (< index size) (return))
311 ;; Optional exponent sign
312 (case (char string index)
314 (#\- (setq exponent-sign -1)
316 (unless (< index size) (return))
318 (let ((value (digit-char-p (char string index))))
319 (unless value (return))
320 (while (and (< index size)
321 (setq value (digit-char-p (char string index))))
322 (setq exponent (+ (* exponent 10) value))
324 (unless (= index size) (return))
325 ;; Everything went ok, we have a float
326 ;; XXX: Use FLOAT when implemented.
327 (/ (* sign (expt 10.0 (* exponent-sign exponent)) number) divisor 1.0))))
329 (defun !parse-integer (string junk-allow)
333 (size (length string))
335 ;; Leading whitespace
336 (while (and (< index size)
337 (whitespacep (char string index)))
339 (unless (< index size) (return (values nil 0)))
341 (case (char string 0)
346 (unless (and (< index size)
347 (setq value (digit-char-p (char string index))))
348 (return (values nil index)))
351 (while (< index size)
352 (let ((digit (digit-char-p (char string index))))
353 (unless digit (return))
354 (setq value (+ (* value 10) digit))
356 ;; Trailing whitespace
357 (do ((i index (1+ i)))
358 ((or (= i size) (not (whitespacep (char string i))))
359 (and (= i size) (setq index i))))
362 (values (* sign value) index)
363 (values nil index)))))
366 (defun parse-integer (string &key junk-allowed)
367 (multiple-value-bind (num index)
368 (!parse-integer string junk-allowed)
371 (error "Junk detected."))))
374 (defun interpret-token (string)
375 (or (read-integer string)
377 (read-symbol string)))
379 (defun ls-read (stream &optional (eof-error-p t) eof-value)
380 (skip-whitespaces-and-comments stream)
381 (let ((ch (%peek-char stream)))
383 ((or (null ch) (char= ch #\)))
385 (error "End of file")
392 (list 'quote (ls-read stream)))
395 (list 'backquote (ls-read stream)))
398 (read-string stream))
401 (if (eql (%peek-char stream) #\@)
402 (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
403 (list 'unquote (ls-read stream))))
407 (let ((string (read-escaped-until stream #'terminalp)))
408 (interpret-token string))))))
410 (defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
411 (ls-read (make-string-stream string) eof-error-p eof-value))
414 (defun read-from-string (string &optional (eof-errorp t) eof-value)
415 (ls-read-from-string string eof-errorp eof-value))