3 ;; Copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
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.
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.
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/>.
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)))
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 skip-whitespaces-and-comments (stream)
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)))))
69 (defun %read-list (stream)
70 (skip-whitespaces-and-comments stream)
71 (let ((ch (%peek-char stream)))
74 (error "Unspected EOF"))
80 (prog1 (ls-read-1 stream)
81 (skip-whitespaces-and-comments stream)
82 (unless (char= (%read-char stream) #\))
83 (error "')' was expected."))))
85 (cons (ls-read-1 stream) (%read-list stream))))))
87 (defun read-string (stream)
90 (setq ch (%read-char stream))
91 (while (not (eql ch #\"))
93 (error "Unexpected EOF"))
95 (setq ch (%read-char stream)))
96 (setq string (concat string (string ch)))
97 (setq ch (%read-char stream)))
100 (defun read-sharp (stream)
102 (ecase (%read-char stream)
104 (list 'function (ls-read-1 stream)))
105 (#\( (list-to-vector (%read-list stream)))
106 (#\: (make-symbol (string-upcase (read-until stream #'terminalp))))
109 (concat (string (%read-char stream))
110 (read-until stream #'terminalp))))
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))))))
117 (let ((feature (read-until stream #'terminalp)))
119 ((string= feature "common-lisp")
120 (ls-read-1 stream) ;ignore
122 ((string= feature "ecmalisp")
125 (error "Unknown reader form.")))))))
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)
135 (while (and (< index size)
136 (not (char= (char string index) #\:)))
142 (setq package *package*)
147 (setq package "KEYWORD")
148 (setq package (string-upcase (subseq string 0 index))))
150 (when (char= (char string 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.
161 (eq package (find-package "KEYWORD"))
162 (eq package (find-package "JS")))
163 (intern name package)
164 (find-symbol name package))))
166 (defun read-float (string)
170 (fractional-part nil)
175 (size (length string))
177 (when (zerop size) (return))
179 (case (char string index)
183 (unless (< index size) (return))
184 ;; Optional integer part
185 (let ((value (digit-char-p (char string index))))
187 (setq integer-part t)
188 (while (and (< index size)
189 (setq value (digit-char-p (char string index))))
190 (setq number (+ (* number 10) value))
192 (unless (< index size) (return))
193 ;; Decimal point is mandatory if there's no integer part
194 (unless (or integer-part (char= #\. (char string index))) (return))
195 ;; Optional fractional part
196 (when (char= #\. (char string index))
198 (unless (< index size) (return))
199 (let ((value (digit-char-p (char string index))))
201 (setq fractional-part t)
202 (while (and (< index size)
203 (setq value (digit-char-p (char string index))))
204 (setq number (+ (* number 10) value))
205 (setq divisor (* divisor 10))
207 ;; Either left or right part of the dot must be present
208 (unless (or integer-part fractional-part) (return))
209 ;; Exponent is mandatory if there is no fractional part
210 (when (and (= index size) (not fractional-part)) (return))
211 ;; Optional exponent part
214 (unless (member (char-upcase (char string index))
215 '(#\E #\S #\F #\D \#L))
218 (unless (< index size) (return))
219 ;; Optional exponent sign
220 (case (char string index)
222 (#\- (setq exponent-sign -1)
224 (unless (< index size) (return))
226 (let ((value (digit-char-p (char string index))))
227 (unless value (return))
228 (while (and (< index size)
229 (setq value (digit-char-p (char string index))))
230 (setq exponent (+ (* exponent 10) value))
232 (unless (= index size) (return))
233 ;; Everything went ok, we have a float
234 (/ (* sign (expt 10 (* exponent-sign exponent)) number) divisor))))
237 (defun !parse-integer (string junk-allow)
241 (size (length string))
243 ;; Leading whitespace
244 (while (and (< index size)
245 (whitespacep (char string index)))
247 (unless (< index size) (return (values nil 0)))
249 (case (char string 0)
254 (unless (and (< index size)
255 (setq value (digit-char-p (char string index))))
256 (return (values nil index)))
259 (while (< index size)
260 (let ((digit (digit-char-p (char string index))))
261 (unless digit (return))
262 (setq value (+ (* value 10) digit))
264 ;; Trailing whitespace
265 (do ((i index (1+ i)))
266 ((or (= i size) (not (whitespacep (char string i))))
267 (and (= i size) (setq index i))))
270 (values (* sign value) index)
271 (values nil index)))))
274 (defun parse-integer (string &key junk-allowed)
275 (multiple-value-bind (num index)
276 (!parse-integer string junk-allowed)
279 (error "junk detected."))))
281 (defvar *eof* (gensym))
282 (defun ls-read-1 (stream)
283 (skip-whitespaces-and-comments stream)
284 (let ((ch (%peek-char stream)))
286 ((or (null ch) (char= ch #\)))
293 (list 'quote (ls-read-1 stream)))
296 (list 'backquote (ls-read-1 stream)))
299 (read-string stream))
302 (if (eql (%peek-char stream) #\@)
303 (progn (%read-char stream) (list 'unquote-splicing (ls-read-1 stream)))
304 (list 'unquote (ls-read-1 stream))))
308 (let ((string (read-until stream #'terminalp)))
309 (or (values (!parse-integer string nil))
311 (read-symbol string)))))))
313 (defun ls-read (stream &optional (eof-error-p t) eof-value)
314 (let ((x (ls-read-1 stream)))
316 (if eof-error-p (error "EOF") eof-value)
319 (defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
320 (ls-read (make-string-stream string) eof-error-p eof-value))