Refactor reader.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sat, 24 Dec 2016 21:16:53 +0000 (22:16 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sat, 24 Dec 2016 21:16:53 +0000 (22:16 +0100)
* module/mes/read-0.mes (read-hash): New function.
  (read-word): Use it.
  (eat-whitespace): Rewrite.
  (display): Minimal implementation through core.
* lib.c (stderr_): Support printing of strings while booting.

mes.c
module/mes/read-0.mes
posix.c

diff --git a/mes.c b/mes.c
index 4f8596a820df6e2c10844d31cf3380d2e76b529a..d61a8b59aed7082a8391bbb40ea0ab9a3f6a064f 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -101,6 +101,7 @@ scm scm_symbol_call_with_values = {SYMBOL, "call-with-values"};
 scm scm_symbol_current_module = {SYMBOL, "current-module"};
 scm scm_symbol_primitive_load = {SYMBOL, "primitive-load"};
 scm scm_symbol_read_input_file = {SYMBOL, "read-input-file"};
+scm scm_symbol_write = {SYMBOL, "write"};
 scm scm_symbol_display = {SYMBOL, "display"};
 
 scm scm_symbol_car = {SYMBOL, "car"};
index 012a01bb7008f9b9292228402cfc938772a75bdd..de08eb87a5b59a43eee51f3b3459a5791d84782c 100644 (file)
   (define <cell:keyword> 3)
   (define <cell:string> 9)
 
-  (define (newline) (core:stderr (integer->char 10)))
-  (define (display x . reset) #f)
+  (define (newline . rest) (core:stderr (list->string (list (integer->char 10)))))
+  (define (display x . rest) (core:stderr x))
   
   (define (list->symbol lst) (make-symbol lst))
 
                 (if (pair? (cdr clauses))
                     (cons (quote cond) (cdr clauses))))))
 
-  (define (eat-whitespace)
-    ((lambda (c)
-       (cond
-        ((eq? c 32) (read-byte) (eat-whitespace))
-        ((eq? c 10) (read-byte) (eat-whitespace))
-        ((eq? c 9) (read-byte) (eat-whitespace))
-        ((eq? c 12) (read-byte) (eat-whitespace))
-        ((eq? c 13) (read-byte) (eat-whitespace))
-        ((eq? c 59) (begin (read-line-comment (read-byte))
-                           (eat-whitespace)))
-        ((eq? c 35) (begin (read-byte)
-                           (cond ((eq? (peek-byte) 33)
-                                  (read-byte)
-                                  (read-block-comment 33 (read-byte))
-                                  (eat-whitespace))
-                                 ((eq? (peek-byte) 59)
-                                  (read-byte)
-                                  (read-word (read-byte) (list) (list))
-                                  (eat-whitespace))
-                                 ((eq? (peek-byte) 124)
-                                  (read-byte)
-                                  (read-block-comment 124 (read-byte))
-                                  (eat-whitespace))
-                                 (#t (unread-byte 35)))))))
-     (peek-byte)))
+  (define (eat-whitespace c)
+    (cond
+     ((eq? c 32) (eat-whitespace (read-byte)))
+     ((eq? c 10) (eat-whitespace (read-byte)))
+     ((eq? c 9) (eat-whitespace (read-byte)))
+     ((eq? c 12) (eat-whitespace (read-byte)))
+     ((eq? c 13) (eat-whitespace (read-byte)))
+     ((eq? c 59) (begin (read-line-comment c)
+                        (eat-whitespace (read-byte))))
+     ((eq? c 35) (cond ((eq? (peek-byte) 33)
+                        (read-byte)
+                        (read-block-comment 33 (read-byte))
+                        (eat-whitespace (read-byte)))
+                       ((eq? (peek-byte) 59)
+                        (read-byte)
+                        (read-word (read-byte) (list) (list))
+                        (eat-whitespace (read-byte)))
+                       ((eq? (peek-byte) 124)
+                        (read-byte)
+                        (read-block-comment 124 (read-byte))
+                        (eat-whitespace (read-byte)))
+                       (#t (unread-byte 35))))
+     (#t (unread-byte c))))
   
   (define (read-block-comment s c)
     (if (eq? c s) (if (eq? (peek-byte) 35) (read-byte)
         (read-line-comment (read-byte))))
 
   (define (read-list a)
-    (eat-whitespace)
+    (eat-whitespace (read-byte))
     (if (eq? (peek-byte) 41) (begin (read-byte) (list))
         ((lambda (w)
            (if (eq? w *dot*) (car (read-list a))
   (define (lookup w a)
     (core:lookup (map1 integer->char w) a))
 
+  (define (read-hash c w a)
+    (cond
+     ((eq? c 33) (begin (read-block-comment 33 (read-byte))
+                        (read-word (read-byte) w a)))
+     ((eq? c 124) (begin (read-block-comment 124 (read-byte))
+                         (read-word (read-byte) w a)))
+     ((eq? c 40) (list->vector (read-list a)))
+     ((eq? c 92) (read-character))
+     ((eq? c 120) (read-hex))
+     ((eq? c 44) (cond ((eq? (peek-byte) 64)
+                        (read-byte)
+                        (cons (quote unsyntax-splicing)
+                              (cons (read-word (read-byte) w a) w)))
+                       (#t (cons (quote unsyntax)
+                                 (cons (read-word (read-byte) w a) w)))))
+     ((eq? c 39) (cons (quote syntax) (cons (read-word (read-byte) w a) w)))
+     ((eq? c 58) (symbol->keyword (read-word (read-byte) w a)))
+     ((eq? c 59) (begin (read-word (read-byte) w a)
+                        (read-word (read-byte) w a)))
+     ((eq? c 96) (cons (quote quasisyntax)
+                       (cons (read-word (read-byte) w a) w)))
+     (#t (read-word c (append2 w (cons 35 w)) a))))
+    
   (define (read-word c w a)
     (cond
-     ((eq? c 32) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))
-     ((eq? c 10) (read-word 32 w a))
-     ((eq? c 9) (read-word 32 w a))
-     ((eq? c 12) (read-word 32 w a))
+     ((or (and (> c 96) (< c 123))
+          (eq? c 45)
+          (eq? c 63)
+          (and (> c 47) (< c 58))) (read-word (read-byte) (append2 w (cons c (list))) a))
+     ((eq? c 40) (if (null? w) (read-list a)
+                     (begin (unread-byte c) (lookup w a))))
+     ((eq? c 41) (if (null? w) (quote *FOOBAR*)
+                     (begin (unread-byte c) (lookup w a))))
      ((eq? c 34) (if (null? w) (read-string)
                      (begin (unread-byte c) (lookup w a))))
-     ((eq? c 35) (cond
-                  ((eq? (peek-byte) 33) (begin (read-byte)
-                                               (read-block-comment 33 (read-byte))
-                                               (read-word (read-byte) w a)))
-                  ((eq? (peek-byte) 124) (begin (read-byte)
-                                                (read-block-comment 124 (read-byte))
-                                                (read-word (read-byte) w a)))
-                  ((eq? (peek-byte) 40) (read-byte) (list->vector (read-list a)))
-                  ((eq? (peek-byte) 92) (read-byte) (read-character))
-                  ((eq? (peek-byte) 120) (read-byte) (read-hex))
-                  ((eq? (peek-byte) 44)
-                   (read-byte)
-                   (cond ((eq? (peek-byte) 64)
-                          (read-byte)
-                          (cons (quote unsyntax-splicing)
-                                (cons (read-word (read-byte) w a) (list))))
-                         (#t
-                          (cons (quote unsyntax)
-                                (cons (read-word (read-byte) w a) (list))))))
-                  ((eq? (peek-byte) 39) (read-byte)
-                   (cons (quote syntax) (cons (read-word (read-byte) w a) (list))))
-                  ((eq? (peek-byte) 58) (read-byte)
-                   (symbol->keyword (read-word (read-byte) (list) a)))
-                  ((eq? (peek-byte) 59) (read-byte)
-                   (read-word (read-byte) w a)
-                   (read-word (read-byte) w a))
-                  ((eq? (peek-byte) 96) (read-byte)
-                   (cons (quote quasisyntax)
-                         (cons (read-word (read-byte) w a) (list))))
-                  (#t (read-word (read-byte) (append2 w (cons c (list))) a))))
+     ((eq? c 32) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))
+     ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))
+     ((eq? c 35) (read-hash (read-byte) w a))
      ((eq? c 39) (if (null? w) (cons (quote quote)
                                      (cons (read-word (read-byte) w a) (list)))
                      (begin (unread-byte c) (lookup w a))))
-     ((eq? c 40) (if (null? w) (read-list a)
-                     (begin (unread-byte c) (lookup w a))))
-     ((eq? c 41) (if (null? w) (quote *FOOBAR*)
-                     (begin (unread-byte c) (lookup w a))))
      ((eq? c 44) (cond
                   ((eq? (peek-byte) 64)
                    (begin (read-byte)
                             (cons (read-word (read-byte) w a) (list))))))
      ((eq? c 96) (cons (quote quasiquote) (cons (read-word (read-byte) w a) (list))))
      ((eq? c 59) (read-line-comment c) (read-word 10 w a))
+     ((eq? c 9) (read-word 32 w a))
+     ((eq? c 12) (read-word 32 w a))
      ((eq? c -1) (list))
      (#t (read-word (read-byte) (append2 w (cons c (list))) a))))
 
diff --git a/posix.c b/posix.c
index 5a95ec7e5de8f2d13c32422b6a26018e728958ac..19197dd611129921f4131e59ab9cad7b4e71b907 100644 (file)
--- a/posix.c
+++ b/posix.c
@@ -82,8 +82,10 @@ write_byte (SCM x) ///((arity . n))
 SCM
 stderr_ (SCM x)
 {
-  SCM display;
-  if ((display = assq_ref_cache (cell_symbol_display, r0)) != cell_undefined)
+  SCM write;
+  if (TYPE (x) == STRING)
+    fprintf (stderr, string_to_cstring (x));
+  else if ((write = assq_ref_cache (cell_symbol_write, r0)) != cell_undefined)
     apply_env (assq_ref_cache (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0);
   else if (TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL)
     fprintf (stderr, string_to_cstring (x));