From af30ac8066de2cf7d1302d2e7b8509f3f2c03091 Mon Sep 17 00:00:00 2001
From: Justin Ethier <justin.ethier@gmail.com>
Date: Wed, 16 Aug 2017 14:36:37 +0000
Subject: [PATCH] Cut over to faster reader for files

---
 read.scm        |   2 +-
 runtime.c       |   5 ++-
 scheme/read.sld | 104 +++++++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 108 insertions(+), 3 deletions(-)

diff --git a/read.scm b/read.scm
index de0724c4..09e0bad9 100644
--- a/read.scm
+++ b/read.scm
@@ -709,7 +709,7 @@
 
 (write
   ;(call-parse2 (open-input-file "scheme/cyclone/cgen.sld")))
-  (call-parse2 (open-input-file "test.scm")))
+  (call-parse2 (open-input-file "test.out")))
   ;(read-token (open-input-file "test.scm")))
 
 ;TODO: getting there, but still not parsed correctly:
diff --git a/runtime.c b/runtime.c
index 3aadf3a9..2f15c8e9 100644
--- a/runtime.c
+++ b/runtime.c
@@ -5682,11 +5682,14 @@ void Cyc_import_shared_object(void *data, object cont, object filename, object e
 /** Read */
 int read_from_port(port_type *p)
 {
-  size_t rv;
+  size_t rv = 0;
   FILE *fp = p->fp;
   char *buf = p->mem_buf;
 
   rv = fread(buf, sizeof(char), CYC_IO_BUF_LEN, fp);
+  //if (NULL == fgets(buf, CYC_IO_BUF_LEN, fp)) {
+  //  rv = 0;
+  //}
   p->mem_buf_len = rv;
   p->buf_idx = 0;
   return rv;
diff --git a/scheme/read.sld b/scheme/read.sld
index 60389163..3491ac51 100644
--- a/scheme/read.sld
+++ b/scheme/read.sld
@@ -703,7 +703,9 @@
     (let ((fp (if (null? args)
                   (current-input-port)
                   (car args))))
-      (parse fp '() '() #f #f 0 (reg-port fp)))))
+      (if (reading-from-file? fp)
+          (call-parse2 fp)
+          (parse fp '() '() #f #f 0 (reg-port fp))))))
 
 ;; read-all -> port -> [objects]
 (define (read-all . args)
@@ -729,4 +731,104 @@
 ;  (repl))
 ;(repl)
 
+;;;;
+;;;; New, faster parser
+;;;;
+
+(define-c reading-from-file?
+  "(void *data, int argc, closure _, object k, object port)"
+  " object result = boolean_f;
+    Cyc_check_port(data, port);
+    if (((port_type *)port)->flags == 1) {
+      result = boolean_t;
+    }
+    return_closcall1(data, k, result);")
+
+(define-c read-token
+  "(void *data, int argc, closure _, object k, object port)"
+  " Cyc_io_read_token(data, k, port);")
+
+(define-c Cyc-opaque-eq?
+  "(void *data, int argc, closure _, object k, object opq, object obj)"
+  " if (Cyc_is_opaque(opq) == boolean_f) 
+      return_closcall1(data, k, boolean_f);
+    return_closcall1(data, k, equalp( opaque_ptr(opq), obj ));")
+
+(define-c Cyc-opaque-unsafe-eq?
+  "(void *data, int argc, closure _, object k, object opq, object obj)"
+  " return_closcall1(data, k, equalp( opaque_ptr(opq), obj ));")
+
+(define (call-parse2 fp)
+  (let ((result (parse2 fp)))
+    (if (Cyc-opaque? result)
+        (error "unexpected closing parenthesis")
+        result)))
+
+(define (parse2 fp)
+  (let ((token (read-token fp))) ;; TODO: this will be a C call
+    ;(write `(token ,token))
+    (cond
+      ((Cyc-opaque? token)
+       (cond
+         ;; Open paren, start read loop
+         ((Cyc-opaque-unsafe-eq? token #\()
+          (let loop ((lis '())
+                     (t (parse2 fp)))
+            (cond
+              ((eof-object? t)
+               (error "missing closing parenthesis"))
+              ((Cyc-opaque-eq? t #\))
+               (if (and (> (length lis) 2)
+                        (equal? (cadr lis) (string->symbol ".")))
+                   (->dotted-list (reverse lis))
+                   (reverse lis)))
+              (else
+               (loop (cons t lis) (parse2 fp))))))
+         ((Cyc-opaque-unsafe-eq? token #\')
+          (list 'quote (parse2 fp)))
+         ((Cyc-opaque-unsafe-eq? token #\`)
+          (list 'quasiquote (parse2 fp)))
+         ((Cyc-opaque-unsafe-eq? token #\,)
+          (list 'unquote (parse2 fp)))
+         (else
+          token))) ;; TODO: error if this is returned to original caller of parse2
+      ((vector? token)
+       (cond
+        ((= (vector-length token) 2) ;; Special case: number
+         (string->number (vector-ref token 0) (vector-ref token 1)))
+        ((= (vector-length token) 3) ;; Special case: exact/inexact number
+         (if (vector-ref token 2)
+             (exact (string->number (vector-ref token 0) (vector-ref token 1)))
+             (inexact (string->number (vector-ref token 0) (vector-ref token 1)))))
+        ((= (vector-length token) 1) ;; Special case: error
+         (error (vector-ref token 0)))
+        (else
+         (let loop ((lis '())
+                    (t (parse2 fp)))
+           (cond
+             ((eof-object? t)
+              (error "missing closing parenthesis"))
+             ((Cyc-opaque-eq? t #\))
+              (list->vector (reverse lis)))
+             (else
+              (loop (cons t lis) (parse2 fp))))))))
+      ((bytevector? token)
+       (let loop ((lis '())
+                  (t (parse2 fp)))
+         (cond
+           ((eof-object? t)
+            (error "missing closing parenthesis"))
+           ((Cyc-opaque-eq? t #\))
+            (apply bytevector (reverse lis)))
+           (else
+            (loop (cons t lis) (parse2 fp))))))
+      ((eq? token (string->symbol ",@"))
+       (list 'unquote-splicing (parse2 fp)))
+      ((eq? token (string->symbol "#;"))
+       (parse2 fp) ;; Ignore next datum
+       (parse2 fp))
+      ;; Other special cases?
+      (else
+        token))))
+
   ))