X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fread.lisp;h=4116bb63754160877be51ddd5510015cacce0e4b;hb=14795770b0fd9ad416fe4db121be1c197e338c95;hp=b33bee67a36adf2a3f953208043b7607ad681c9e;hpb=b62cf4a43e2694e9b985cd575b45f8a89c534d2d;p=jscl.git

diff --git a/src/read.lisp b/src/read.lisp
index b33bee6..4116bb6 100644
--- a/src/read.lisp
+++ b/src/read.lisp
@@ -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,27 @@
       ((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
+                              (discard-char stream #\)))
+                            (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,11 +137,11 @@
       (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))))
     (#\\
@@ -129,20 +149,21 @@
             (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)))))))
 
 (defun unescape (x)
   (let ((result ""))
@@ -151,6 +172,27 @@
         (setq result (concat result (string (char x i))))))
     result))
 
+(defun escape-all (x)
+  (let ((result ""))
+    (dotimes (i (length x))
+      (setq result (concat result "\\"))
+      (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 +209,33 @@
     (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 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)
@@ -205,7 +250,7 @@
            (case elt
              (#\+ nil)
              (#\- (setq sign -1))
-             (otherwise (return-from read-integer))))
+             (t (return-from read-integer))))
           ((and (= i (1- size)) (char= elt #\.)) nil)
           (t (return-from read-integer)))))
     (and number (* sign number))))
@@ -321,50 +366,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 (read-integer string)
-             (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))