X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fread.lisp;h=3c352b33184e451b4470c6e81384ed69284914d4;hb=68cd2db6542fa3442d46b0331ecf8be8f86c09c2;hp=6d015f7d14950131bc4672af46f28055dbf9bd19;hpb=ca49459c0d6de45c45171af22e268db9ce14e31a;p=jscl.git
diff --git a/src/read.lisp b/src/read.lisp
index 6d015f7..3c352b3 100644
--- a/src/read.lisp
+++ b/src/read.lisp
@@ -3,18 +3,18 @@
;; Copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
-;; This program is free software: you can redistribute it and/or
+;; JSCL is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
-;; This program is distributed in the hope that it will be useful, but
+;; JSCL is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see .
+;; along with JSCL. If not, see .
;;;; Reader
@@ -45,7 +45,7 @@
(setq ch (%peek-char stream)))))
(defun terminalp (ch)
- (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
+ (or (null ch) (whitespacep ch) (char= #\" ch) (char= #\) ch) (char= #\( ch)))
(defun read-until (stream func)
(let ((string "")
@@ -59,15 +59,24 @@
(defun read-escaped-until (stream func)
(let ((string "")
- (ch))
- (setq ch (%peek-char stream))
- (while (and ch (not (funcall func ch)))
- (setq string (concat string (string ch)))
+ (ch (%peek-char stream))
+ (multi-escape nil))
+ (while (and ch (or multi-escape (not (funcall func ch))))
+ (cond
+ ((char= ch #\|)
+ (if multi-escape
+ (setf multi-escape nil)
+ (setf multi-escape t)))
+ ((char= ch #\\)
+ (%read-char stream)
+ (setf ch (%peek-char stream))
+ (setf string (concat string "\\" (string ch))))
+ (t
+ (if multi-escape
+ (setf string (concat string "\\" (string ch)))
+ (setf string (concat string (string ch))))))
(%read-char stream)
- (when (char= ch #\\)
- ;; Note... escape char has been left in the string!
- (setq string (concat string (string (%read-char stream)))))
- (setq ch (%peek-char stream)))
+ (setf ch (%peek-char stream)))
string))
(defun skip-whitespaces-and-comments (stream)
@@ -79,6 +88,13 @@
(skip-whitespaces stream)
(setq ch (%peek-char stream)))))
+(defun discard-char (stream expected)
+ (let ((ch (%read-char stream)))
+ (when (null ch)
+ (error "End of file when character ~S was expected." expected))
+ (unless (char= ch expected)
+ (error "Character ~S was found but ~S was expected." ch expected))))
+
(defun %read-list (stream)
(skip-whitespaces-and-comments stream)
(let ((ch (%peek-char stream)))
@@ -86,23 +102,31 @@
((null ch)
(error "Unspected EOF"))
((char= ch #\))
- (%read-char stream)
+ (discard-char stream #\))
nil)
(t
- (let ((car (ls-read-1 stream)))
+ (let* ((eof (gensym))
+ (next (ls-read stream nil eof)))
(skip-whitespaces-and-comments stream)
- (cons car
- (if (char= (%peek-char stream) #\.)
- (progn
- (%read-char stream)
- (if (terminalp (%peek-char stream))
- (ls-read-1 stream) ; Dotted pair notation
- (cons (let ((string (concat "." (read-escaped-until stream #'terminalp))))
- (or (values (!parse-integer string nil))
- (read-float string)
- (read-symbol string)))
- (%read-list stream))))
- (%read-list stream))))))))
+ (cond
+ ((eq next eof)
+ (discard-char stream #\)))
+ (t
+ (cons next
+ (if (char= (%peek-char stream) #\.)
+ (progn
+ (discard-char stream #\.)
+ (if (terminalp (%peek-char stream))
+ (prog1 (ls-read stream) ; Dotted pair notation
+ (skip-whitespaces-and-comments stream)
+ (let ((ch (%peek-char stream)))
+ (if (or (null ch) (char= #\) ch))
+ (discard-char stream #\))
+ (error "Multiple objects following . in a list"))))
+ (let ((token (concat "." (read-escaped-until stream #'terminalp))))
+ (cons (interpret-token token)
+ (%read-list stream)))))
+ (%read-list stream))))))))))
(defun read-string (stream)
(let ((string "")
@@ -117,40 +141,61 @@
(setq ch (%read-char stream)))
string))
-(defun read-sharp (stream)
+(defun read-sharp (stream &optional eof-error-p eof-value)
(%read-char stream)
(ecase (%read-char stream)
(#\'
- (list 'function (ls-read-1 stream)))
+ (list 'function (ls-read stream)))
(#\( (list-to-vector (%read-list stream)))
- (#\: (make-symbol (string-upcase (read-until stream #'terminalp))))
+ (#\: (make-symbol
+ (unescape-token
+ (string-upcase-noescaped
+ (read-escaped-until stream #'terminalp)))))
(#\\
(let ((cname
(concat (string (%read-char stream))
(read-until stream #'terminalp))))
(cond
- ((string= cname "space") (char-code #\space))
- ((string= cname "tab") (char-code #\tab))
- ((string= cname "newline") (char-code #\newline))
- (t (char-code (char cname 0))))))
+ ((string= cname "space") #\space)
+ ((string= cname "tab") #\tab)
+ ((string= cname "newline") #\newline)
+ (t (char cname 0)))))
(#\+
- (let ((feature (read-until stream #'terminalp)))
- (cond
- ((string= feature "common-lisp")
- (ls-read-1 stream) ;ignore
- (ls-read-1 stream))
- ((string= feature "jscl")
- (ls-read-1 stream))
- (t
- (error "Unknown reader form.")))))))
+ (let ((feature (let ((symbol (ls-read stream)))
+ (unless (symbolp symbol)
+ (error "Invalid feature ~S" symbol))
+ (intern (string symbol) "KEYWORD"))))
+ (ecase feature
+ (:common-lisp
+ (ls-read stream)
+ (ls-read stream eof-error-p eof-value))
+ (:jscl
+ (ls-read stream eof-error-p eof-value))
+ (:nil
+ (ls-read stream)
+ (ls-read stream eof-error-p eof-value)))))))
-(defun unescape (x)
+(defun unescape-token (x)
(let ((result ""))
(dotimes (i (length x))
(unless (char= (char x i) #\\)
(setq result (concat result (string (char x i))))))
result))
+(defun string-upcase-noescaped (s)
+ (let ((result "")
+ (last-escape nil))
+ (dotimes (i (length s))
+ (let ((ch (char s i)))
+ (if last-escape
+ (progn
+ (setf last-escape nil)
+ (setf result (concat result (string ch))))
+ (if (char= ch #\\)
+ (setf last-escape t)
+ (setf result (concat result (string-upcase (string ch))))))))
+ result))
+
;;; Parse a string of the form NAME, PACKAGE:NAME or
;;; PACKAGE::NAME and return the name. If the string is of the
;;; form 1) or 3), but the symbol does not exist, it will be created
@@ -167,30 +212,51 @@
(cond
;; No package prefix
((= index size)
- (setq name (unescape string))
+ (setq name string)
(setq package *package*)
(setq internalp t))
(t
;; Package prefix
(if (zerop index)
(setq package "KEYWORD")
- (setq package (string-upcase (unescape (subseq string 0 index)))))
+ (setq package (string-upcase-noescaped (subseq string 0 index))))
(incf index)
(when (char= (char string index) #\:)
(setq internalp t)
(incf index))
- (setq name (unescape (subseq string index)))))
+ (setq name (subseq string index))))
;; Canonalize symbol name and package
- (when (not (eq package "JS"))
- (setq name (string-upcase name)))
+ (setq name (if (equal package "JS")
+ (setq name (unescape-token name))
+ (setq name (string-upcase-noescaped name))))
(setq package (find-package package))
- ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an
- ;; external symbol from PACKAGE.
(if (or internalp
(eq package (find-package "KEYWORD"))
(eq package (find-package "JS")))
(intern name package)
- (find-symbol name package))))
+ (multiple-value-bind (symbol external)
+ (find-symbol name package)
+ (if (eq external :external)
+ symbol
+ (error "The symbol `~S' is not external in the package ~S." name package))))))
+
+(defun read-integer (string)
+ (let ((sign 1)
+ (number nil)
+ (size (length string)))
+ (dotimes (i size)
+ (let ((elt (char string i)))
+ (cond
+ ((digit-char-p elt)
+ (setq number (+ (* (or number 0) 10) (digit-char-p elt))))
+ ((zerop i)
+ (case elt
+ (#\+ nil)
+ (#\- (setq sign -1))
+ (t (return-from read-integer))))
+ ((and (= i (1- size)) (char= elt #\.)) nil)
+ (t (return-from read-integer)))))
+ (and number (* sign number))))
(defun read-float (string)
(block nil
@@ -238,8 +304,7 @@
;; Optional exponent part
(when (< index size)
;; Exponent-marker
- (unless (member (string-upcase (string (char string index)))
- '("E" "S" "F" "D" "L"))
+ (unless (find (char-upcase (char string index)) "ESFDL")
(return))
(incf index)
(unless (< index size) (return))
@@ -258,8 +323,8 @@
(incf index))))
(unless (= index size) (return))
;; Everything went ok, we have a float
- (/ (* sign (expt 10.0 (* exponent-sign exponent)) number) divisor))))
-
+ ;; XXX: Use FLOAT when implemented.
+ (/ (* sign (expt 10.0 (* exponent-sign exponent)) number) divisor 1.0))))
(defun !parse-integer (string junk-allow)
(block nil
@@ -303,50 +368,44 @@
(!parse-integer string junk-allowed)
(if num
(values num index)
- (error "junk detected."))))
+ (error "Junk detected."))))
+
-(defvar *eof* (gensym))
-(defun ls-read-1 (stream)
+(defun interpret-token (string)
+ (or (read-integer string)
+ (read-float string)
+ (read-symbol string)))
+
+(defun ls-read (stream &optional (eof-error-p t) eof-value)
(skip-whitespaces-and-comments stream)
(let ((ch (%peek-char stream)))
(cond
((or (null ch) (char= ch #\)))
- *eof*)
+ (if eof-error-p
+ (error "End of file")
+ eof-value))
((char= ch #\()
(%read-char stream)
(%read-list stream))
((char= ch #\')
(%read-char stream)
- (list 'quote (ls-read-1 stream)))
+ (list 'quote (ls-read stream)))
((char= ch #\`)
(%read-char stream)
- (list 'backquote (ls-read-1 stream)))
+ (list 'backquote (ls-read stream)))
((char= ch #\")
(%read-char stream)
(read-string stream))
((char= ch #\,)
(%read-char stream)
(if (eql (%peek-char stream) #\@)
- (progn (%read-char stream) (list 'unquote-splicing (ls-read-1 stream)))
- (list 'unquote (ls-read-1 stream))))
+ (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
+ (list 'unquote (ls-read stream))))
((char= ch #\#)
(read-sharp stream))
- ((char= ch #\|)
- (%read-char stream)
- (let ((string (read-escaped-until stream (lambda (x) (char= x #\|)))))
- (%read-char stream)
- (read-symbol string)))
(t
(let ((string (read-escaped-until stream #'terminalp)))
- (or (values (!parse-integer string nil))
- (read-float string)
- (read-symbol string)))))))
-
-(defun ls-read (stream &optional (eof-error-p t) eof-value)
- (let ((x (ls-read-1 stream)))
- (if (eq x *eof*)
- (if eof-error-p (error "EOF") eof-value)
- x)))
+ (interpret-token string))))))
(defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
(ls-read (make-string-stream string) eof-error-p eof-value))