mes: resurrect full reader in C core.
authorJan Nieuwenhuizen <janneke@gnu.org>
Wed, 29 Nov 2017 20:42:50 +0000 (21:42 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Wed, 29 Nov 2017 20:42:50 +0000 (21:42 +0100)
* module/mes/read-0.mes (defined?): New function.
  (eat-whitespace, read-env, read-word, read-block-comment,
  read-line-comment, read-list, read-character, read-hex, read-octal,
  reader:read-string, lookup, read-hash, read-word): Only define if
  not %c-reader.
* module/mes/base-0.mes (defined?): Remove.
* src/mes.c[MES_C_READER]: Set ARENA_SIZE=10000000.
  (scm_symbol_quasiquote scm_symbol_unquote,
  scm_symbol_unquote_splicing, scm_symbol_syntax,
  scm_symbol_quasisyntax, scm_symbol_unsyntax,
  scm_symbol_unsyntax_splicing): New symbol.
  (scm_symbol_c_reader): New symbol.
  (MAKE_KEYWORD)[MES_C_READER]: New define.
  (mes_symbols): Define %c_reader.
* src/reader.c (read_word_)[MES_C_READER]: Extend to full Scheme
  reader.
  (eat_whitespace)[MES_C_READER]: Likewise.
  (read_block_comment, read_hash, read_word, read_character,
  read_octal, read_hex, append_char, read_string)[MES_C_READER]:
  Likewise.
* make.scm (bin.gcc,bin.mescc): Define MES_C_READER=1.

make.scm
module/mes/base-0.mes
module/mes/read-0.mes
module/mes/scm.mes
src/mes.c
src/reader.c

index 841fbec5d2da43478b0b1b2bb9796d72c6a57709..dc707a502adedbeb8f171b884200f573afa1ce66 100755 (executable)
--- a/make.scm
+++ b/make.scm
@@ -413,7 +413,8 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
    (add-target (snarf "src/vector.c" #:mes? #t))))
 
 (add-target (bin.gcc "src/mes.c" #:dependencies gcc-snarf-targets
-                     #:defines `("FIXED_PRIMITIVES=1"
+                     #:defines `("MES_C_READER=1"
+                                 "MES_FIXED_PRIMITIVES=1"
                                  "MES_FULL=1"
                                  "POSIX=1"
                                  ,(string-append "VERSION=\"" %version "\"")
@@ -423,7 +424,8 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
 
 (add-target (bin.gcc "src/mes.c" #:libc libc-gcc.mlibc-o
                      #:dependencies mes-snarf-targets
-                     #:defines `("FIXED_PRIMITIVES=1"
+                     #:defines `("MES_C_READER=1"
+                                 "MES_FIXED_PRIMITIVES=1"
                                  "MES_FULL=1"
                                  ,(string-append "VERSION=\"" %version "\"")
                                  ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") "/" %moduledir "/") "\"")
@@ -431,7 +433,8 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
                      #:includes '("src")))
 
 (add-target (bin.mescc "src/mes.c" #:dependencies mes-snarf-targets
-                       #:defines `("FIXED_PRIMITIVES=1"
+                       #:defines `("MES_C_READER=1"
+                                   "MES_FIXED_PRIMITIVES=1"
                                    "MES_FULL=1"
                                    ,(string-append "VERSION=\"" %version "\"")
                                    ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"")
index 01a8b466ffe4dce83ed60937961cf7a60aaab488..f575d32a85c5e094f845df759103f632727feb73 100644 (file)
@@ -34,9 +34,6 @@
 (define (primitive-eval e) (core:eval e (current-module)))
 (define eval core:eval)
 
-(define-macro (defined? x)
-  (list 'assq x '(cdr (cdr (current-module)))))
-
 (if (defined? 'current-input-port) #t
     (define (current-input-port) 0))
 
index 31a25ec16085b4dc0cfdd93a3f83c300b50b89eb..247b7bf538fc3559952b023c68b8ceb8a3f72d12 100644 (file)
   (define (symbol->keyword s)
     (core:make-cell <cell:keyword> (symbol->list s) 0))
 
-  (define (read)
-    (read-word (read-byte) (list) (current-module)))
-
-  (define (read-env a)
-    (read-word (read-byte) (list) a))
-
-  (define (read-input-file)
-    (define (helper x)
-      (if (null? x) x
-          (cons x (helper (read)))))
-    (helper (read)))
+  (define-macro (defined? x)
+    (list (quote assq) x (quote (cdr (cdr (current-module))))))
 
   (define-macro (cond . clauses)
     (list (quote if) (pair? clauses)
                 (if (pair? (cdr clauses))
                     (cons (quote cond) (cdr clauses))))))
 
-  (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-block-comment s (read-byte)))
-        (read-block-comment s (read-byte))))
-
-  (define (read-line-comment c)
-    (if (eq? c 10) c
-        (read-line-comment (read-byte))))
-
-  (define (read-list a)
-    (eat-whitespace (read-byte))
-    (if (eq? (peek-byte) 41) (begin (read-byte) (list))
-        ((lambda (w)
-           (if (eq? w *dot*) (car (read-list a))
-               (cons w (read-list a))))
-         (read-word (read-byte) (list) a))))
-
   (define-macro (and . x)
     (if (null? x) #t
         (if (null? (cdr x)) (car x)
   (define (not x)
     (if x #f #t))
   
-  (define (read-character)
-    (define (read-octal c p n)
-      (if (not (and (> p 47) (< p 56))) n
-          (read-octal (read-byte) (peek-byte) (+ (ash n 3) (- p 48)))))
-
-    (define (read-name c p n)
-      (define (lookup-char n)
-        (cond ((assq n (quote ((*foe* . -1)
-                               (lun . 0)
-                               (mrala . 7)
-                               (ecapskcab . 8)
-                               (bat . 9)
-                               (enilwen . 10)
-                               (batv . 11)
-                               (egap . 12)
-                               (nruter . 13)
-                               (rc . 13)
-                               (ecaps . 32)))) => cdr)
-              (#t (error (quote char-not-supported) n))))
-      (if (not (or (eq? p 42) (and (> p 96) (< p 123)))) (integer->char (lookup-char (list->symbol (cons (integer->char c) n))))
-          (read-name (read-byte) (peek-byte) (cons (integer->char c) n))))
-
-    ((lambda (c p)
-       (cond ((and (> c 47) (< c 56) (> p 47) (< p 56))
-              (integer->char (read-octal c p (- c 48))))
-             ((and (or (= c 42) (and (> c 96) (< c 123)))
-                   (or (= p 42) (and (> p 96) (< p 123)))) (read-name c p (list)))
-             (#t (integer->char c))))
-     (read-byte) (peek-byte)))
-
-  (define (read-hex)
-    (define (calc c)
-      (cond ((and (> c 64) (< c 71)) (+ (- c 65) 10))
-            ((and (> c 96) (< c 103)) (+ (- c 97) 10))
-            ((and (> c 47) (< c 58)) (- c 48))
-            (#t 0)))
-    (define (read-hex c p s n)
-      (if (not (or (and (> p 64) (< p 71))
-                   (and (> p 96) (< p 103))
-                   (and (> p 47) (< p 58)))) (* s (+ (ash n 4) (calc c)))
-                   (read-hex (read-byte) (peek-byte) s (+ (ash n 4) (calc c)))))
-    ((lambda (c p)
-       (if (eq? c 45) (read-hex (read-byte) (peek-byte) -1 0)
-           (read-hex c p 1 0)))
-     (read-byte) (peek-byte)))
-
-  (define (read-octal)
-    (define (read-octal c p s n)
-      (if (not (or (and (> p 47) (< p 56)))) (* s (+ (ash n 3) (- c 48)))
-          (read-octal (read-byte) (peek-byte) s (+ (ash n 3) (- c 48)))))
-    ((lambda (c p)
-       (if (eq? c 45) (read-octal (read-byte) (peek-byte) -1 0)
-           (read-octal c p 1 0)))
-     (read-byte) (peek-byte)))
-
-  (define (reader:read-string)
-    (define (append-char s c)
-      (append2 s (cons (integer->char c) (list))))
-    (define (reader:read-string c p s)
-      (cond
-       ((and (eq? c 92) (or (eq? p 92) (eq? p 34)))
-        ((lambda (c)
-           (reader:read-string (read-byte) (peek-byte) (append-char s c)))
-         (read-byte)))
-       ((and (eq? c 92) (eq? p 110))
-        (read-byte)
-        (reader:read-string (read-byte) (peek-byte) (append-char s 10)))
-       ((and (eq? c 92) (eq? p 116))
-        (read-byte)
-        (reader:read-string (read-byte) (peek-byte) (append-char s 9)))
-       ((eq? c 34) s)
-       ((eq? c -1) (error (quote EOF-in-string) (cons c s)))
-       (#t (reader:read-string (read-byte) (peek-byte) (append-char s c)))))
-    (list->string (reader:read-string (read-byte) (peek-byte) (list))))
-
   (define (map1 f lst)
     (if (null? lst) (list)
         (cons (f (car lst)) (map1 f (cdr lst)))))
 
-  (define (lookup w a)
-    (define (lookup-number c p s n)
-      (and (> c 47) (< c 58)
-           (if (null? p) (* s (+ (* n 10) (- c 48)))
-               (lookup-number (car p) (cdr p) s (+ (* n 10) (- c 48))))))
-    ((lambda (c p)
-       (or (cond ((and (> c 47) (< c 58)) (lookup-number c p 1 0))
-                 ((and (eq? c 45) (pair? p)) (lookup-number (car p) (cdr p) -1 0))
-                 (#t #f))
-           (core:lookup-symbol (map1 integer->char w))))
-     (car w) (cdr w)))
-
-  (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 111) (read-octal))
-     ((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
-     ((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 10) (if (null? w) (read-word (read-byte) (list) a) (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 34) (if (null? w) (reader:read-string)
-                     (begin (unread-byte c) (lookup w 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 44) (cond
-                  ((eq? (peek-byte) 64)
-                   (begin (read-byte)
-                          (cons
-                           (quote unquote-splicing)
-                           (cons (read-word (read-byte) w a) (list)))))
-                  (#t (cons (quote unquote)
-                            (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))))
+  (define (read)
+    (read-word (read-byte) (list) (current-module)))
+
+  (define (read-input-file)
+    (core:read-input-file-env (read-env (current-module)) (current-module)))
+
+  (if (not %c-reader)
+      (begin
+        (define (read-env a)
+          (read-word (read-byte) (list) a))
+
+        (define (read-input-file)
+          (define (helper x)
+            (if (null? x) x
+                (cons x (helper (read)))))
+          (helper (read)))
+
+        (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-block-comment s (read-byte)))
+              (read-block-comment s (read-byte))))
+
+        (define (read-line-comment c)
+          (if (eq? c 10) c
+              (read-line-comment (read-byte))))
+
+        (define (read-list a)
+          (eat-whitespace (read-byte))
+          (if (eq? (peek-byte) 41) (begin (read-byte) (list))
+              ((lambda (w)
+                 (if (eq? w *dot*) (car (read-list a))
+                     (cons w (read-list a))))
+               (read-word (read-byte) (list) a))))
+
+        (define (read-character)
+          (define (read-octal c p n)
+            (if (not (and (> p 47) (< p 56))) n
+                (read-octal (read-byte) (peek-byte) (+ (ash n 3) (- p 48)))))
+
+          (define (read-name c p n)
+            (define (lookup-char n)
+              (cond ((assq n (quote ((*foe* . -1)
+                                     (lun . 0)
+                                     (mrala . 7)
+                                     (ecapskcab . 8)
+                                     (bat . 9)
+                                     (enilwen . 10)
+                                     (batv . 11)
+                                     (egap . 12)
+                                     (nruter . 13)
+                                     (rc . 13)
+                                     (ecaps . 32)))) => cdr)
+                    (#t (error (quote char-not-supported) n))))
+            (if (not (or (eq? p 42) (and (> p 96) (< p 123)))) (integer->char (lookup-char (list->symbol (cons (integer->char c) n))))
+                (read-name (read-byte) (peek-byte) (cons (integer->char c) n))))
+
+          ((lambda (c p)
+             (cond ((and (> c 47) (< c 56) (> p 47) (< p 56))
+                    (integer->char (read-octal c p (- c 48))))
+                   ((and (or (= c 42) (and (> c 96) (< c 123)))
+                         (or (= p 42) (and (> p 96) (< p 123)))) (read-name c p (list)))
+                   (#t (integer->char c))))
+           (read-byte) (peek-byte)))
+
+        (define (read-hex)
+          (define (calc c)
+            (cond ((and (> c 64) (< c 71)) (+ (- c 65) 10))
+                  ((and (> c 96) (< c 103)) (+ (- c 97) 10))
+                  ((and (> c 47) (< c 58)) (- c 48))
+                  (#t 0)))
+          (define (read-hex c p s n)
+            (if (not (or (and (> p 64) (< p 71))
+                         (and (> p 96) (< p 103))
+                         (and (> p 47) (< p 58)))) (* s (+ (ash n 4) (calc c)))
+                         (read-hex (read-byte) (peek-byte) s (+ (ash n 4) (calc c)))))
+          ((lambda (c p)
+             (if (eq? c 45) (read-hex (read-byte) (peek-byte) -1 0)
+                 (read-hex c p 1 0)))
+           (read-byte) (peek-byte)))
+
+        (define (read-octal)
+          (define (read-octal c p s n)
+            (if (not (or (and (> p 47) (< p 56)))) (* s (+ (ash n 3) (- c 48)))
+                (read-octal (read-byte) (peek-byte) s (+ (ash n 3) (- c 48)))))
+          ((lambda (c p)
+             (if (eq? c 45) (read-octal (read-byte) (peek-byte) -1 0)
+                 (read-octal c p 1 0)))
+           (read-byte) (peek-byte)))
+
+        (define (reader:read-string)
+          (define (append-char s c)
+            (append2 s (cons (integer->char c) (list))))
+          (define (reader:read-string c p s)
+            (cond
+             ((and (eq? c 92) (or (eq? p 92) (eq? p 34)))
+              ((lambda (c)
+                 (reader:read-string (read-byte) (peek-byte) (append-char s c)))
+               (read-byte)))
+             ((and (eq? c 92) (eq? p 110))
+              (read-byte)
+              (reader:read-string (read-byte) (peek-byte) (append-char s 10)))
+             ((and (eq? c 92) (eq? p 116))
+              (read-byte)
+              (reader:read-string (read-byte) (peek-byte) (append-char s 9)))
+             ((eq? c 34) s)
+             ((eq? c -1) (error (quote EOF-in-string) (cons c s)))
+             (#t (reader:read-string (read-byte) (peek-byte) (append-char s c)))))
+          (list->string (reader:read-string (read-byte) (peek-byte) (list))))
+
+        (define (lookup w a)
+          (define (lookup-number c p s n)
+            (and (> c 47) (< c 58)
+                 (if (null? p) (* s (+ (* n 10) (- c 48)))
+                     (lookup-number (car p) (cdr p) s (+ (* n 10) (- c 48))))))
+          ((lambda (c p)
+             (or (cond ((and (> c 47) (< c 58)) (lookup-number c p 1 0))
+                       ((and (eq? c 45) (pair? p)) (lookup-number (car p) (cdr p) -1 0))
+                       (#t #f))
+                 (core:lookup-symbol (map1 integer->char w))))
+           (car w) (cdr w)))
+
+        (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 111) (read-octal))
+           ((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
+           ((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 10) (if (null? w) (read-word (read-byte) (list) a) (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 34) (if (null? w) (reader:read-string)
+                           (begin (unread-byte c) (lookup w 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 44) (cond
+                        ((eq? (peek-byte) 64)
+                         (begin (read-byte)
+                                (cons
+                                 (quote unquote-splicing)
+                                 (cons (read-word (read-byte) w a) (list)))))
+                        (#t (cons (quote unquote)
+                                  (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))))))
 
   ((lambda (p)
      (core:eval (cons (quote begin) p) (current-module)))
index cc8c4dce9132650c68174cb3c5426e3698480c03..020c39492a4f6c60ec714d1227120eb4e795c6a3 100644 (file)
   (or (and (number? x) (= x -1))
       (and (char? x) (eof-object? (char->integer x)))))
 
-(define (peek-char)
-  (integer->char (peek-byte)))
+(if (not (defined? 'peek-char))
+    (define (peek-char)
+      (integer->char (peek-byte))))
 
-(define (read-char)
-  (integer->char (read-byte)))
+(if (not (defined? 'read-char))
+    (define (read-char)
+      (integer->char (read-byte))))
 
-(define (unread-char c)
-  (unread-byte (char->integer c))
-  c)
+(if (not (defined? 'unread-char))
+    (define (unread-char c)
+      (unread-byte (char->integer c))))
 
 (define (assq-set! alist key val)
   (let ((entry (assq key alist)))
index f8fce51109ab5d7a1c5a8404fac5b640b6e45de7..d410153a7ae9b556faf6fdf64191883b33025b06 100644 (file)
--- a/src/mes.c
+++ b/src/mes.c
 #include <string.h>
 #include <mlibc.h>
 
+#if MES_C_READER
+int ARENA_SIZE = 10000000;
+#else
 int ARENA_SIZE = 100000;
+#endif
 int MAX_ARENA_SIZE = 20000000;
+
 //int GC_SAFETY_DIV = 400;
 //int GC_SAFETY = ARENA_SIZE / 400;
 int GC_SAFETY = 250;
@@ -126,6 +131,19 @@ struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0};
 struct scm scm_symbol_begin = {TSYMBOL, "begin",0};
 struct scm scm_symbol_if = {TSYMBOL, "if",0};
 struct scm scm_symbol_quote = {TSYMBOL, "quote",0};
+
+#if 1
+//MES_C_READER
+//Only for MES_C_READER; snarfing makes these always needed for linking
+struct scm scm_symbol_quasiquote = {TSYMBOL, "quasiquote", 0};
+struct scm scm_symbol_unquote = {TSYMBOL, "unquote", 0};
+struct scm scm_symbol_unquote_splicing = {TSYMBOL, "unquote-splicing", 0};
+struct scm scm_symbol_syntax = {TSYMBOL, "syntax",0};
+struct scm scm_symbol_quasisyntax = {TSYMBOL, "quasisyntax", 0};
+struct scm scm_symbol_unsyntax = {TSYMBOL, "unsyntax", 0};
+struct scm scm_symbol_unsyntax_splicing = {TSYMBOL, "unsyntax-splicing", 0};
+#endif // MES_C_READER
+
 struct scm scm_symbol_set_x = {TSYMBOL, "set!",0};
 
 struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0};
@@ -165,7 +183,7 @@ struct scm scm_vm_apply = {TSPECIAL, "core:apply",0};
 struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0};
 struct scm scm_vm_eval = {TSPECIAL, "core:eval",0};
 
-//FIXED_PRIMITIVES
+//MES_FIXED_PRIMITIVES
 struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",0};
 struct scm scm_vm_eval_cdr = {TSPECIAL, "*vm-eval-cdr*",0};
 struct scm scm_vm_eval_cons = {TSPECIAL, "*vm-eval-cons*",0};
@@ -187,6 +205,7 @@ struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0};
 
 struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0};
 struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0};
+struct scm scm_symbol_c_reader = {TSYMBOL, "%c-reader",0};
 
 struct scm scm_test = {TSYMBOL, "test",0};
 
@@ -271,6 +290,9 @@ int g_function = 0;
 #define MAKE_NUMBER(n) make_cell_ (tmp_num_ (TNUMBER), 0, tmp_num2_ (n))
 #define MAKE_REF(n) make_cell_ (tmp_num_ (TREF), n, 0)
 #define MAKE_STRING(x) make_cell_ (tmp_num_ (TSTRING), x, 0)
+#if MES_C_READER
+#define MAKE_KEYWORD(x) make_cell_ (tmp_num_ (TKEYWORD), x, 0)
+#endif
 
 #define CAAR(x) CAR (CAR (x))
 #define CADR(x) CAR (CDR (x))
@@ -717,7 +739,7 @@ eval_apply ()
     case cell_vm_apply: goto apply;
     case cell_vm_apply2: goto apply2;
     case cell_vm_eval: goto eval;
-#if FIXED_PRIMITIVES
+#if MES_FIXED_PRIMITIVES
     case cell_vm_eval_car: goto eval_car;
     case cell_vm_eval_cdr: goto eval_cdr;
     case cell_vm_eval_cons: goto eval_cons;
@@ -851,7 +873,7 @@ eval_apply ()
       {
         switch (CAR (r1))
           {
-#if FIXED_PRIMITIVES
+#if MES_FIXED_PRIMITIVES
           case cell_symbol_car:
             {
               push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
@@ -879,7 +901,7 @@ eval_apply ()
             eval_null_p:
               x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
             }
-#endif // FIXED_PRIMITIVES
+#endif // MES_FIXED_PRIMITIVES
           case cell_symbol_quote:
             {
               x = r1; gc_pop_frame (); r1 = CADR (x); goto eval_apply;
@@ -1161,6 +1183,12 @@ mes_symbols () ///((internal))
   a = acons (cell_symbol_mesc, cell_t, a);
 #endif
 
+#if MES_C_READER
+  a = acons (cell_symbol_c_reader, cell_t, a);
+#else
+  a = acons (cell_symbol_c_reader, cell_f, a);
+#endif
+
   a = acons (cell_closure, a, a);
 
   return a;
index 6d52e0d84a4750faa07a3f41857e4790e3ae8def..e0b5510b397e070a442c86570913931b9c631e36 100644 (file)
@@ -44,21 +44,40 @@ read_line_comment (int c)
 }
 
 SCM
-read_word (int c, SCM w, SCM a)
+read_word_ (int c, SCM w, SCM a)
 {
   if (c == EOF && w == cell_nil) return cell_nil;
-  if (c == '\t') return read_word ('\n', w, a);
-  if (c == '\f') return read_word ('\n', w, a);
-  if (c == '\n' && w == cell_nil) return read_word (getchar (), w, a);
+  if (c == '\t') return read_word_ ('\n', w, a);
+  if (c == '\f') return read_word_ ('\n', w, a);
+  if (c == '\n' && w == cell_nil) return read_word_ (getchar (), w, a);
   if (c == '\n' && VALUE (car (w)) == '.' && cdr (w) == cell_nil) return cell_dot;
+  if (c == ' ') return read_word_ ('\n', w, a);
   if (c == EOF || c == '\n') return lookup_ (w, a);
-  if (c == ' ') return read_word ('\n', w, a);
+
   if (c == '(' && w == cell_nil) return read_list (a);
   if (c == '(') {ungetchar (c); return lookup_ (w, a);}
   if (c == ')' && w == cell_nil) {ungetchar (c); return cell_nil;}
   if (c == ')') {ungetchar (c); return lookup_ (w, a);}
-  if (c == ';') {read_line_comment (c); return read_word ('\n', w, a);}
-  return read_word (getchar (), append2 (w, cons (MAKE_CHAR (c), cell_nil)), a);
+  if (c == ';') {read_line_comment (c); return read_word_ ('\n', w, a);}
+
+#if MES_C_READER
+  if (c == '"' && w == cell_nil) return read_string ();
+  if (c == '"') {ungetchar (c); return lookup_ (w, a);}
+  if (c == ',' && peekchar () == '@') {getchar (); return cons (cell_symbol_unquote_splicing,
+                                                                cons (read_word_ (getchar (), w, a),
+                                                                      cell_nil));}
+  if (c == '\'') return cons (cell_symbol_quote, cons (read_word_ (getchar (), w, a), cell_nil));
+  if (c == '`') return cons (cell_symbol_quasiquote, cons (read_word_ (getchar (), w, a), cell_nil));
+  if (c == ',') return cons (cell_symbol_unquote, cons (read_word_ (getchar (), w, a), cell_nil));
+
+  if (c == '#' && peekchar () == '!') {c = getchar (); read_block_comment (c, getchar ()); return read_word_ (getchar (), w, a);}
+  if (c == '#' && peekchar () == '|') {c = getchar (); read_block_comment (c, getchar ()); return read_word_ (getchar (), w, a);}
+  if (c == '#' && peekchar () == 'f') return read_word_ (getchar (), append2 (w, cons (MAKE_CHAR (c), cell_nil)), a);
+  if (c == '#' && peekchar () == 't') return read_word_ (getchar (), append2 (w, cons (MAKE_CHAR (c), cell_nil)), a);
+  if (c == '#') return read_hash (getchar (), w, a);
+#endif //MES_C_READER
+
+  return read_word_ (getchar (), append2 (w, cons (MAKE_CHAR (c), cell_nil)), a);
 }
 
 int
@@ -66,6 +85,9 @@ eat_whitespace (int c)
 {
   while (c == ' ' || c == '\t' || c == '\n' || c == '\f') c = getchar ();
   if (c == ';') return eat_whitespace (read_line_comment (c));
+#if MES_C_READER
+  if (c == '#' && (peekchar () == '!' || peekchar () == '|')) {c=getchar (); read_block_comment (c, getchar ()); return eat_whitespace (getchar ());}
+#endif
   return c;
 }
 
@@ -75,7 +97,7 @@ read_list (SCM a)
   int c = getchar ();
   c = eat_whitespace (c);
   if (c == ')') return cell_nil;
-  SCM w = read_word (c, cell_nil, a);
+  SCM w = read_word_ (c, cell_nil, a);
   if (w == cell_dot)
     return car (read_list (a));
   return cons (w, read_list (a));
@@ -84,7 +106,7 @@ read_list (SCM a)
 SCM
 read_env (SCM a)
 {
-  return read_word (getchar (), cell_nil, a);
+  return read_word_ (getchar (), cell_nil, a);
 }
 
 SCM
@@ -109,6 +131,176 @@ lookup_ (SCM s, SCM a)
   return lookup_symbol_ (s);
 }
 
+#if MES_C_READER
+SCM
+read_block_comment (int s, int c)
+{
+  if (c == s && peekchar () == '#') return getchar ();
+  return read_block_comment (s, getchar ());
+}
+
+SCM
+read_hash (int c, SCM w, SCM a)
+{
+  if (c == ',')
+    {
+      if (peekchar () == '@')
+        {
+          getchar ();
+          return cons (cell_symbol_unsyntax_splicing, cons (read_word_ (getchar (), w, a), cell_nil));
+        }
+      return cons (cell_symbol_unsyntax, cons (read_word_ (getchar (), w, a), cell_nil));
+    }
+  if (c == '\'') return cons (cell_symbol_syntax, cons (read_word_ (getchar (), w, a), cell_nil));
+  if (c == '`') return cons (cell_symbol_quasisyntax, cons (read_word_ (getchar (), w, a), cell_nil));
+  if (c == ':') return MAKE_KEYWORD (CAR (read_word_ (getchar (), cell_nil, a)));
+  if (c == 'o') return read_octal ();
+  if (c == 'x') return read_hex ();
+  if (c == '\\') return read_character ();
+  if (c == '(') return list_to_vector (read_list (a));
+  if (c == ';') read_word_ (getchar (), w, a); return read_word_ (getchar (), w, a);
+  if (c == '!') {read_block_comment (c, getchar ()); return read_word_ (getchar (), w, a);}
+  if (c == '|') {read_block_comment (c, getchar ()); return read_word_ (getchar (), w, a);}
+  if (c == 'f') return cell_f;
+  if (c == 't') return cell_t;
+
+  return read_word_ (getchar (), append2 (w, cons (MAKE_CHAR (c), cell_nil)), a);
+}
+
+SCM
+read_word (SCM c, SCM w, SCM a)
+{
+  return read_word_ (VALUE (c), w, a);
+}
+
+SCM
+read_character ()
+{
+  int c = getchar ();
+  if (c >= '0' && c <= '7'
+      && peekchar () >= '0' && peekchar () <= '7')
+    {
+      c = c - '0';
+      while (peekchar () >= '0' && peekchar () <= '7')
+        {
+          c <<= 3;
+          c += getchar () - '0';
+        }
+    }
+  else if (((c >= 'a' && c <= 'z')
+            || c == '*')
+           && ((peekchar () >= 'a' && peekchar () <= 'z')
+               || peekchar () == '*'))
+    {
+      char buf[10];
+      char *p = buf;
+      *p++ = c;
+      while ((peekchar () >= 'a' && peekchar () <= 'z')
+             || peekchar () == '*')
+        {
+          *p++ = getchar ();
+        }
+      *p = 0;
+      if (!strcmp (buf, "*eof*")) c = EOF;
+      else if (!strcmp (buf, "nul")) c = '\0';
+      else if (!strcmp (buf, "alarm")) c = '\a';
+      else if (!strcmp (buf, "backspace")) c = '\b';
+      else if (!strcmp (buf, "tab")) c = '\t';
+      else if (!strcmp (buf, "newline")) c = '\n';
+      else if (!strcmp (buf, "vtab")) c = '\v';
+      else if (!strcmp (buf, "page")) c = '\f';
+#if __MESC__
+      //Nyacc bug
+      else if (!strcmp (buf, "return")) c = 13;
+      else if (!strcmp (buf, "cr")) c = 13;
+#else
+      else if (!strcmp (buf, "return")) c = '\r';
+      else if (!strcmp (buf, "cr")) c = '\r';
+#endif
+      else if (!strcmp (buf, "space")) c = ' ';
+      else
+        {
+          eputs ("char not supported: ");
+          eputs (buf);
+          eputs ("\n");
+#if !__MESC__
+          assert (!"char not supported");
+#endif
+        }
+    }
+  return MAKE_CHAR (c);
+}
+
+SCM
+read_octal ()
+{
+  int n = 0;
+  int c = peekchar ();
+  int s = 1;
+  if (c == '-') {s = -1;getchar (); c = peekchar ();}
+  while (c >= '0' && c <= '7')
+    {
+      n <<= 3;
+      n+= c - '0';
+      getchar ();
+      c = peekchar ();
+    }
+  return MAKE_NUMBER (s*n);
+}
+
+SCM
+read_hex ()
+{
+  int n = 0;
+  int c = peekchar ();
+  int s = 1;
+  if (c == '-') {s = -1;getchar (); c = peekchar ();}
+  while ((c >= '0' && c <= '9')
+         || (c >= 'A' && c <= 'F')
+         || (c >= 'a' && c <= 'f'))
+    {
+      n <<= 4;
+      if (c >= 'a') n += c - 'a' + 10;
+      else if (c >= 'A') n += c - 'A' + 10;
+      else n+= c - '0';
+      getchar ();
+      c = peekchar ();
+    }
+  return MAKE_NUMBER (s*n);
+}
+
+SCM
+append_char (SCM x, int i)
+{
+  return append2 (x, cons (MAKE_CHAR (i), cell_nil));
+}
+
+SCM
+read_string ()
+{
+  SCM p = cell_nil;
+  int c = getchar ();
+  while (1) {
+    if (c == '"') break;
+    if (c == '\\' && peekchar () == '\\') p = append_char (p, getchar ());
+    else if (c == '\\' && peekchar () == '"') p = append_char (p, getchar ());
+    else if (c == '\\' && peekchar () == 'n') {getchar (); p = append_char (p, '\n');}
+#if !__MESC__
+    else if (c == EOF) assert (!"EOF in string");
+#endif
+    else p = append_char (p, c);
+    c = getchar ();
+  }
+  return MAKE_STRING (p);
+}
+#else // !MES_C_READER
+SCM read_word (SCM c,SCM w,SCM a) {}
+SCM read_character () {}
+SCM read_octal () {}
+SCM read_hex () {}
+SCM read_string () {}
+#endif // MES_C_READER
+
 int g_tiny = 0;
 
 int