read: improper lists

1 files changed, 40 insertions, 26 deletions

diff --git a/read.scm b/read.scm
index 7158f58..a7fde06 100644
--- a/read.scm
+++ b/read.scm
@@ -19,6 +19,11 @@
 (load "set.scm")
 (load "linked-list.scm")
 
+;;; My text editor cannot parse Scheme's character syntax.
+
+(define %bol #\()
+(define %eol #\))
+
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Port reader wrapper
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
@@ -228,7 +233,7 @@
    (list readtable:exclude-from-identifiers
          readtable:ASCII-whitespace)
    (list readtable:exclude-from-identifiers
-         (list #\| #\( #\) #\' #\; #f))))
+         (list #\| %bol %eol #\' #\; #f))))
 
 ;;; Read an identifier starting with CHAR.
 (define readtable:read-ident
@@ -255,52 +260,60 @@
    (readtable:empty/default readtable:skip)
    (list readtable:update #\newline (readtable:return #f))))
 
+;;; Read the end of an improper list.
+(define readtable:read-improper-cdr
+  (lambda (table acc port)
+    (let ((val
+           (readtable:act (readtable:update table
+                                            %eol
+                                            (readtable:error
+                                             "proper list must have cdr"))
+                          (port 'read)
+                          #f
+                          port)))
+      (acc 'set-cdr! val)
+      (let ((table (readtable:process
+                    (readtable:empty/default (readtable:error
+                                              "improper list has 1 cdr"))
+                    (list readtable:add-all-as-skip readtable:ASCII-whitespace)
+                    (list readtable:update %eol
+                          (lambda dummy acc)))))
+        (readtable:act table (port 'read) acc port)))))
+
 ;;; List reader.
 ;;; 
 ;;; The reader updates the previous readtable to handle ). This means
 ;;; that this read table does not have to handle end-of-line, whitespace,
 ;;; etc.
-;;; 
-;;; TODO: Put improper list into new function
 (define readtable:read-list
-  (lambda (table char acc port)
+  (lambda (oldtable char acc port)
     (let ((acc (linked-list:new))
           (table (readtable:process
-                  table
-                  (list readtable:update #\)
+                  oldtable
+                  (list readtable:update %eol
                         (readtable:return 'end-of-list))
                   (list readtable:update #\.
                         (lambda (table char acc port)
                           (let ((id (readtable:read-ident
                                      table
                                      char
-                                     acc
+                                     #f
                                      port)))
+                            ;; todo: list needs a car
                             (if (equal? id ".")
-                                'period
+                                (begin
+                                  (readtable:read-improper-cdr
+                                   oldtable acc port)
+                                  'end-of-list)
                                 id)))))))
       (letrec ((loop
                 (lambda ()
                   (let ((value (readtable:act table
                                               (port 'read)
-                                              #f
+                                              acc
                                               port)))
                     (cond
                       ((eqv? value 'end-of-list) (acc 'to-list))
-                      ((eqv? value 'period)
-                       (let ((final-value (readtable:act table
-                                                         (port 'read)
-                                                         #f
-                                                         port)))
-                         (acc 'set-cdr! final-value)
-                         (let ((expect-eol (readtable:act table
-                                                          (port 'read)
-                                                          #f
-                                                          port)))
-                           (if (not (eqv? expect-eol 'end-of-list))
-                               (error "found instead of end of improper list"
-                                      expect-eol)
-                               (acc 'to-list)))))
                       (else (acc 'push-tail value)
                             (loop)))))))
         (loop)))))
@@ -314,8 +327,8 @@
      (readtable:empty/default readtable:read-ident)
      (list readtable:add-all-as-skip readtable:ASCII-whitespace)
      (list readtable:update #f (readtable:return 'eof))
-     (list readtable:update #\( readtable:read-list)
-     (list readtable:update #\) (readtable:error "unbalanced list"))
+     (list readtable:update %bol readtable:read-list)
+     (list readtable:update %eol (readtable:error "unbalanced list"))
      (list readtable:update #\;
            (readtable:jump-discard readtable:read-to-newline)))))
 
@@ -351,4 +364,5 @@
 
 (read-all "x yy zz ; this is a comment\nx call/cc ")
 (read-all "(a   b    c     def (ghi j)  k    )")
-(read-all "(a . b)")
+(read-all "(      a . b   )")
+(read-all "(   a .b . c)")