readtable: add lists

README.rst

@@ -19,7 +19,7 @@ designed to be used by a severely limited Scheme interpreter, which
 * has fixnums only
 * only uses immutable strings
 * does not use "load" recursively
-* uses R3RS essential procedures only (with some exceptions)
+* uses R3RS essential procedures/syntax only (with some exceptions)
 
 The goal is to have the compiler run under the MiniScheme in ``miniscm``
 in DOS, and then run in GLLV to compile itself.

read.scm

@@ -17,6 +17,7 @@
 (load "chez-compat.scm")
 (load "util.scm")
 (load "set.scm")
+(load "linked-list.scm")
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Port reader wrapper
@@ -159,6 +160,12 @@
 ;;; Default readtables
 ;;; ;;;;;;;;;;;;;;;;;;
 
+;;; Return an error.
+(define readtable:error
+  (lambda emsg
+    (lambda tablemsg
+      (apply error tablemsg emsg))))
+
 ;;; Discard the current character and continue reading the readtable.
 (define readtable:skip
   (lambda (table char acc port)
@@ -178,6 +185,12 @@
       (readtable:act newtable (port 'read) '() port)
       (readtable:act oldtable (port 'read) acc port))))
 
+;;; Jump to a new readtable with the same characters.
+(define readtable:jump
+  (lambda (newtable)
+    (lambda (oldtable char acc port)
+      (readtable:act newtable char acc port))))
+
 ;;; Push back CHAR and return ACC.
 (define readtable:return-acc-keep-char
   (lambda (table char acc port)
@@ -185,9 +198,10 @@
     acc))
 
 ;;; Push CHAR to ACC and continue reading from TABLE.
-(define readtable:push-acc
+(define readtable:push-char
   (lambda (table char acc port)
-    (readtable:act table (port 'read) (cons char acc) port)))
+    (acc 'push-tail char)
+    (readtable:act table (port 'read) acc port)))
 
 ;;; Define a readtable that constructs an identifier by accepting all
 ;;; characters that are not listed.
@@ -210,7 +224,7 @@
 ;;; Readtable for identifiers.
 (define readtable:identifier
   (readtable:process
-   (readtable:empty/default readtable:push-acc)
+   (readtable:empty/default readtable:push-char)
    (list readtable:exclude-from-identifiers
          readtable:ASCII-whitespace)
    (list readtable:exclude-from-identifiers
@@ -219,8 +233,12 @@
 ;;; Read an identifier starting with CHAR.
 (define readtable:read-ident
   (lambda (table char acc port)
-    (reverse (readtable:act readtable:identifier
+    (let ((lst (linked-list:new)))
-                            (port 'read) (list char) port))))
+      (lst 'push char)
+      (list->string
+       ((readtable:act readtable:identifier
+                     (port 'read) lst port)
+        'to-list)))))
 
 ;;; Add all chars in TO-SKIP to TABLE as skipped characters. Used for
 ;;; whitespace.
@@ -237,14 +255,69 @@
    (readtable:empty/default readtable:skip)
    (list readtable:update #\newline (readtable:return #f))))
 
+;;; 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)
+    (let ((acc (linked-list:new))
+          (table (readtable:process
+                  table
+                  (list readtable:update #\)
+                        (readtable:return 'end-of-list))
+                  (list readtable:update #\.
+                        (lambda (table char acc port)
+                          (let ((id (readtable:read-ident
+                                     table
+                                     char
+                                     acc
+                                     port)))
+                            (if (equal? id ".")
+                                'period
+                                id)))))))
+      (letrec ((loop
+                (lambda ()
+                  (let ((value (readtable:act table
+                                              (port 'read)
+                                              #f
+                                              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)))))
+
 ;;; Toplevel reader.
+;;; This is defined as a function so that it dynamically loads each
+;;; sub-readtable.
 (define readtable:top
+  (lambda ()
     (readtable:process
      (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 #\;
-         (readtable:jump-discard readtable:read-to-newline))))
+           (readtable:jump-discard readtable:read-to-newline)))))
 
 ;;; ;;;;;;;;;;;
 ;;; Test reader
@@ -268,7 +341,7 @@
                   (if (not (reader 'peek))
                       #t
                       (let ((value (readtable:act
-                                    readtable:top (reader 'read)
+                                    (readtable:top) (reader 'read)
                                     #f
                                     reader)))
                         (display (list "return" value))
@@ -277,5 +350,5 @@
         (loop)))))
 
 (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)")