Extend Scheme reader, reduce C reader dependency.

* mes.c (bload_env): Mark as internal.
  (load_env): Likewise.  Load Scheme reader from source.  Remove dumping.
  (dump): New function.
* (vm_begin_env): Allow for gc while read_input_file_env.
  (mes_builtins): Add *dot*.
  (read_input_file_env)[!READER]: Invoke read-input-file.
* module/mes/read-0.mes (read-env): New function.
  (read-word): Support quasisyntax.
  Remove usage of ' thoughout.
* module/mes/repl.mes (repl): Use read instead of read-env.
* guile/mes.scm (environment): Add *dot*.
* guile/reader.mes: Update.
* NEWS: Update.

diff --git a/NEWS b/NEWS
index 71cdabd9ac0bc7b4ad08ffce7d66a4548a3c756f..aeda4e79f7c3e83704a95c5b5cee25f0f4c09fbc 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -10,6 +10,12 @@ Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
 
 Please send Mes bug reports to janneke@gnu.org.
 
 
 Please send Mes bug reports to janneke@gnu.org.
 

+* Changes in 0.4 since 0.3
+** Core
+*** Smaller C-reader
+The C-reader needs only support reading of words and lists
+(s-expressions), line-comments.  Quoting, characters, strings,
+block-comments are all handled by the Scheme reader later.

 * Changes in 0.3 since 0.2
 ** Core
 *** Number-based rather than pointer-based cells.
 * Changes in 0.3 since 0.2
 ** Core
 *** Number-based rather than pointer-based cells.

diff --git a/guile/mes.scm b/guile/mes.scm
index 5128df03cbb529214bed7d0b961c50d08e8f1076..d9830a5e8c898e83016754e9f1cb72871fdb5992 100755 (executable)
--- a/guile/mes.scm
+++ b/guile/mes.scm
@@ -211,6 +211,7 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
     (exit . guile:exit)
 
     (*macro* . (guile:list))
     (exit . guile:exit)
 
     (*macro* . (guile:list))

+    (*dot* . '.)

 
     ;;
     (stderr . stderr))))
 
     ;;
     (stderr . stderr))))

diff --git a/guile/reader.mes b/guile/reader.mes
index bb42194ba72cfcd6459091b96956618d31481ad6..d1fc56fe66ddc2e36582b0f17adc109b5da9329a 100644 (file)
--- a/guile/reader.mes
+++ b/guile/reader.mes
@@ -37,7 +37,7 @@
   ;; * read characters, quote, strings
 
   (define (read)
   ;; * read characters, quote, strings
 
   (define (read)

-    (read-word (read-byte) '() (current-module)))
+    (read-word (read-byte) (list) (current-module)))

 
   (define (read-input-file)
     (define (helper x)
 
   (define (read-input-file)
     (define (helper x)


@@ -46,18 +46,18 @@
     (helper (read)))
 
   (define-macro (cond . clauses)
     (helper (read)))
 
   (define-macro (cond . clauses)

-    (list 'if (null? clauses) *unspecified*
+    (list (quote if) (null? clauses) *unspecified*

           (if (null? (cdr clauses))
           (if (null? (cdr clauses))

-              (list 'if (car (car clauses))
-                    (list (cons 'lambda (cons '() (cons (car (car clauses)) (cdr (car clauses))))))
+              (list (quote if) (car (car clauses))
+                    (list (cons (quote lambda) (cons (list) (cons (car (car clauses)) (cdr (car clauses))))))

                     *unspecified*)
                     *unspecified*)

-              (if (eq? (car (cadr clauses)) 'else)
-                  (list 'if (car (car clauses))
-                        (list (cons 'lambda (cons '() (car clauses))))
-                        (list (cons 'lambda (cons '() (cons *unspecified* (cdr (cadr clauses)))))))
-                  (list 'if (car (car clauses))
-                        (list (cons 'lambda (cons '() (car clauses))))
-                        (cons 'cond (cdr clauses)))))))
+              (if (eq? (car (cadr clauses)) (quote else))
+                  (list (quote if) (car (car clauses))
+                        (list (cons (quote lambda) (cons (list) (car clauses))))
+                        (list (cons (quote lambda) (cons (list) (cons *unspecified* (cdr (cadr clauses)))))))
+                  (list (quote if) (car (car clauses))
+                        (list (cons (quote lambda) (cons (list) (car clauses))))
+                        (cons (quote cond) (cdr clauses)))))))

 
   (define (eat-whitespace)
     (cond
 
   (define (eat-whitespace)
     (cond


@@ -88,21 +88,21 @@
 
   (define (read-list a)
     (eat-whitespace)
 
   (define (read-list a)
     (eat-whitespace)

-    (if (eq? (peek-byte) 41) (begin (read-byte) '())
+    (if (eq? (peek-byte) 41) (begin (read-byte) (list))

         ((lambda (w)
         ((lambda (w)

-           (if (eq? w '.) (car (read-list a))
+           (if (eq? w *dot*) (car (read-list a))

                (cons w (read-list a))))
                (cons w (read-list a))))

-         (read-word (read-byte) '() a))))
+         (read-word (read-byte) (list) a))))

 
   ;;(define (read-string))
 
   (define (lookup-char c a)
 
   ;;(define (read-string))
 
   (define (lookup-char c a)

-    (lookup (cons (integer->char c) '()) a))
+    (lookup (cons (integer->char c) (list)) a))

 
   (define (read-word c w a)
     (cond
 
   (define (read-word c w a)
     (cond

-      ((eq? c -1) '())
-      ((eq? c 10) (if (null? w) (read-word (read-byte) '() a)
+      ((eq? c -1) (list))
+      ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a)

                       (lookup w a)))
       ((eq? c 32) (read-word 10 w a))
       ((eq? c 34) (if (null? w) (read-string)
                       (lookup w a)))
       ((eq? c 32) (read-word 10 w a))
       ((eq? c 34) (if (null? w) (read-string)


@@ -114,28 +114,28 @@
                    ((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) 40) (read-byte) (list->vector (read-list a)))
                    ((eq? (peek-byte) 92) (read-byte) (read-character))
                    ((eq? (peek-byte) 120) (read-byte) (read-hex))

-                   (else (read-word (read-byte) (append2 w (cons (integer->char c) '())) a))))
-      ((eq? c 39) (if (null? w) (cons (lookup (cons (integer->char c) '()) a)
-                                      (cons (read-word (read-byte) w a) '()))
+                   (else (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
+      ((eq? c 39) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
+                                      (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))))
                       (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) (cons (lookup (cons (integer->char c) '()) a)
-                                      (cons (read-word (read-byte) w a) '()))
+      ((eq? c 41) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
+                                      (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
                       (begin (unread-byte c) (lookup w a))))
       ((eq? c 44) (cond
                    ((eq? (peek-byte) 64) (begin (read-byte)
                                                 (cons

-                                                 (lookup (symbol->list 'unquote-splicing) a)
-                                                 (cons (read-word (read-byte) w a) '()))))
+                                                 (lookup (symbol->list (quote unquote-splicing)) a)
+                                                 (cons (read-word (read-byte) w a) (list)))))

                    (else  (cons (lookup-char c a) (cons (read-word (read-byte) w a)
                    (else  (cons (lookup-char c a) (cons (read-word (read-byte) w a)

-                                                        '())))))
-      ((eq? c 96) (cons (lookup-char c a) (cons (read-word (read-byte) w a) '())))
+                                                        (list))))))
+      ((eq? c 96) (cons (lookup-char c a) (cons (read-word (read-byte) w a) (list))))

       ((eq? c 59) (read-line-comment c) (read-word 10 w a))
       ((eq? c 59) (read-line-comment c) (read-word 10 w a))

-      (else (read-word (read-byte) (append2 w (cons (integer->char c) '())) a))))
+      (else (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))

 
   ;; ((lambda (p)
 
   ;; ((lambda (p)

-  ;;    ;;(display 'program=) (display p) (newline)
+  ;;    ;;(display (quote program=)) (display p) (newline)

   ;;    (begin-env p (current-module)))
   ;;  (read-input-file))
   )
   ;;    (begin-env p (current-module)))
   ;;  (read-input-file))
   )

diff --git a/mes.c b/mes.c
index 1d3f1765fa994557ea5baae1e28c95a51e75b036..bee6a3946255e564f0ec2c296bed43a94156dbc4 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -33,8 +33,13 @@
 #define QUASISYNTAX 0
 #define ENV_CACHE 0
 #define FIXED_PRIMITIVES 1
 #define QUASISYNTAX 0
 #define ENV_CACHE 0
 #define FIXED_PRIMITIVES 1

+#define READER 1

 
 

+#if READER
+int ARENA_SIZE = 1000000;
+#else

 int ARENA_SIZE = 100000;
 int ARENA_SIZE = 100000;

+#endif

 int MAX_ARENA_SIZE = 20000000;
 int GC_SAFETY = 100;
 
 int MAX_ARENA_SIZE = 20000000;
 int GC_SAFETY = 100;
 


@@ -141,6 +146,7 @@ scm scm_symbol_unsyntax_splicing = {SYMBOL, "unsyntax-splicing"};
 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_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_the_unquoters = {SYMBOL, "*the-unquoters*"};
 
 
 scm scm_symbol_the_unquoters = {SYMBOL, "*the-unquoters*"};
 


@@ -527,7 +533,10 @@ vm_begin_env ()
         if (caar (r1) == cell_symbol_begin)
           r1 = append2 (cdar (r1), cdr (r1));
         else if (caar (r1) == cell_symbol_primitive_load)
         if (caar (r1) == cell_symbol_begin)
           r1 = append2 (cdar (r1), cdr (r1));
         else if (caar (r1) == cell_symbol_primitive_load)

-          r1 = append2 (read_input_file_env (r0), cdr (r1));
+          {
+            SCM f = read_input_file_env (r0);
+            r1 = append2 (f, cdr (r1));
+          }

       }
     r = eval_env (car (r1), r0);
     r1 = CDR (r1);
       }
     r = eval_env (car (r1), r0);
     r1 = CDR (r1);


@@ -1130,6 +1139,7 @@ mes_builtins (SCM a)
   a = acons (cell_symbol_the_unquoters, the_unquoters, a);
 #endif
 
   a = acons (cell_symbol_the_unquoters, the_unquoters, a);
 #endif
 

+  a = add_environment (a, "*dot*", cell_dot);

   a = add_environment (a, "*foo-bar-baz*", cell_nil); // FIXME: some off-by one?
 
   return a;
   a = add_environment (a, "*foo-bar-baz*", cell_nil); // FIXME: some off-by one?
 
   return a;


@@ -1184,39 +1194,29 @@ read_input_file_env_ (SCM e, SCM a)
 SCM
 read_input_file_env (SCM a)
 {
 SCM
 read_input_file_env (SCM a)
 {

+  r0 = a;
+#if READER

   return read_input_file_env_ (read_env (r0), r0);
   return read_input_file_env_ (read_env (r0), r0);

+#endif
+  return apply_env (cell_symbol_read_input_file, cell_nil, r0);

 }
 
 }
 

-bool g_dump_p = false;
-

 SCM
 SCM

-load_env (SCM a)
+load_env (SCM a) ///((internal))

 {
 {

+  r0 =a;
+#if !READER
+  g_stdin = fopen ("module/mes/read-0.mes", "r");
+  g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mes", "r");
+#endif
+  if (!g_function) r0 = mes_builtins (r0);

   r3 = read_input_file_env (r0);
   r3 = read_input_file_env (r0);

-  if (g_dump_p && !g_function)
-    {
-      r1 = g_symbols;
-      SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
-      stack = cons (frame, stack);
-      stack = gc (stack);
-      gc_frame (stack);
-      char *p = (char*)g_cells;
-      fputc ('M', stdout);
-      fputc ('E', stdout);
-      fputc ('S', stdout);
-      fputc (stack >> 8, stdout);
-      fputc (stack % 256, stdout);
-      for (int i=0; i<g_free.value * sizeof(scm); i++)
-        fputc (*p++, stdout);
-      return 0;
-    }
-  if (!g_function)
-    r0 = mes_builtins (r0);
-  return begin_env (r3, r0);
+  g_stdin = stdin;
+  return r3;

 }
 
 SCM
 }
 
 SCM

-bload_env (SCM a)
+bload_env (SCM a) ///((internal))

 {
   g_stdin = fopen ("module/mes/read-0.mo", "r");
   g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mo", "r");
 {
   g_stdin = fopen ("module/mes/read-0.mo", "r");
   g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mo", "r");


@@ -1238,8 +1238,26 @@ bload_env (SCM a)
   g_stdin = stdin;
 
   r0 = mes_builtins (r0);
   g_stdin = stdin;
 
   r0 = mes_builtins (r0);

+  return r3;
+}

 
 

-  return begin_env (r3, r0);
+int
+dump ()
+{
+  r1 = g_symbols;
+  SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
+  stack = cons (frame, stack);
+  stack = gc (stack);
+  gc_frame (stack);
+  char *p = (char*)g_cells;
+  fputc ('M', stdout);
+  fputc ('E', stdout);
+  fputc ('S', stdout);
+  fputc (stack >> 8, stdout);
+  fputc (stack % 256, stdout);
+  for (int i=0; i<g_free.value * sizeof(scm); i++)
+    fputc (*p++, stdout);
+  return 0;

 }
 
 #include "type.c"
 }
 
 #include "type.c"


@@ -1256,17 +1274,15 @@ int
 main (int argc, char *argv[])
 {
   g_debug = getenv ("MES_DEBUG");
 main (int argc, char *argv[])
 {
   g_debug = getenv ("MES_DEBUG");

-  if (getenv ("MES_ARENA"))
-    ARENA_SIZE = atoi (getenv ("MES_ARENA"));
-  if (argc > 1 && !strcmp (argv[1], "--dump")) g_dump_p = true;
+  if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA"));

   if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes < FILE\n");
   if (argc > 1 && !strcmp (argv[1], "--version")) return puts ("Mes 0.3\n");
   g_stdin = stdin;
   if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes < FILE\n");
   if (argc > 1 && !strcmp (argv[1], "--version")) return puts ("Mes 0.3\n");
   g_stdin = stdin;

-  SCM a = mes_environment ();
-  if (argc > 1 && !strcmp (argv[1], "--load"))
-    display_ (stderr, bload_env (a));
-  else
-    display_ (stderr, load_env (a));
+  r0 = mes_environment ();
+  SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
+    ? bload_env (r0) : load_env (r0);
+  if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
+  display_ (stderr, begin_env (program, r0));

   fputs ("", stderr);
   gc (stack);
   if (g_debug) fprintf (stderr, "\nstats: [%d]\n", g_free.value);
   fputs ("", stderr);
   gc (stack);
   if (g_debug) fprintf (stderr, "\nstats: [%d]\n", g_free.value);

diff --git a/module/mes/read-0.mes b/module/mes/read-0.mes
index f36fff67f3fe0fd8802e0121f447151aa7aed7e7..8d59bb178d89cfd2277238eb1692d77e7cce1cc4 100644 (file)
--- a/module/mes/read-0.mes
+++ b/module/mes/read-0.mes
@@ -42,7 +42,10 @@
   ;; * read characters, quote, strings
 
   (define (read)
   ;; * read characters, quote, strings
 
   (define (read)

-    (read-word (read-byte) '() (current-module)))
+    (read-word (read-byte) (list) (current-module)))
+
+  (define (read-env a)
+    (read-word (read-byte) (list) a))

 
   (define (read-input-file)
     (define (helper x)
 
   (define (read-input-file)
     (define (helper x)


@@ -51,18 +54,18 @@
     (helper (read)))
 
   (define-macro (cond . clauses)
     (helper (read)))
 
   (define-macro (cond . clauses)

-    (list 'if (null? clauses) *unspecified*
+    (list (quote if) (null? clauses) *unspecified*

           (if (null? (cdr clauses))
           (if (null? (cdr clauses))

-              (list 'if (car (car clauses))
-                    (list (cons 'lambda (cons '() (cons (car (car clauses)) (cdr (car clauses))))))
+              (list (quote if) (car (car clauses))
+                    (list (cons (quote lambda) (cons (list) (cons (car (car clauses)) (cdr (car clauses))))))

                     *unspecified*)
                     *unspecified*)

-              (if (eq? (car (cadr clauses)) 'else)
-                  (list 'if (car (car clauses))
-                        (list (cons 'lambda (cons '() (car clauses))))
-                        (list (cons 'lambda (cons '() (cons *unspecified* (cdr (cadr clauses)))))))
-                  (list 'if (car (car clauses))
-                        (list (cons 'lambda (cons '() (car clauses))))
-                        (cons 'cond (cdr clauses)))))))
+              (if (eq? (car (cadr clauses)) (quote else))
+                  (list (quote if) (car (car clauses))
+                        (list (cons (quote lambda) (cons (list) (car clauses))))
+                        (list (cons (quote lambda) (cons (list) (cons *unspecified* (cdr (cadr clauses)))))))
+                  (list (quote if) (car (car clauses))
+                        (list (cons (quote lambda) (cons (list) (car clauses))))
+                        (cons (quote cond) (cdr clauses)))))))

 
   (define (eat-whitespace)
     (cond
 
   (define (eat-whitespace)
     (cond


@@ -93,21 +96,21 @@
 
   (define (read-list a)
     (eat-whitespace)
 
   (define (read-list a)
     (eat-whitespace)

-    (if (eq? (peek-byte) 41) (begin (read-byte) '())
+    (if (eq? (peek-byte) 41) (begin (read-byte) (list))

         ((lambda (w)
         ((lambda (w)

-           (if (eq? w '.) (car (read-list a))
+           (if (eq? w *dot*) (car (read-list a))

                (cons w (read-list a))))
                (cons w (read-list a))))

-         (read-word (read-byte) '() a))))
+         (read-word (read-byte) (list) a))))

 
   ;;(define (read-string))
 
   (define (lookup-char c a)
 
   ;;(define (read-string))
 
   (define (lookup-char c a)

-    (lookup (cons (integer->char c) '()) a))
+    (lookup (cons (integer->char c) (list)) a))

 
   (define (read-word c w a)
     (cond
 
   (define (read-word c w a)
     (cond

-      ((eq? c -1) '())
-      ((eq? c 10) (if (null? w) (read-word (read-byte) '() a)
+      ((eq? c -1) (list))
+      ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a)

                       (lookup w a)))
       ((eq? c 32) (read-word 10 w a))
       ((eq? c 34) (if (null? w) (read-string)
                       (lookup w a)))
       ((eq? c 32) (read-word 10 w a))
       ((eq? c 34) (if (null? w) (read-string)


@@ -119,27 +122,42 @@
                    ((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) 40) (read-byte) (list->vector (read-list a)))
                    ((eq? (peek-byte) 92) (read-byte) (read-character))
                    ((eq? (peek-byte) 120) (read-byte) (read-hex))

-                   (else (read-word (read-byte) (append w (cons (integer->char c) '())) a))))
-      ((eq? c 39) (if (null? w) (cons (lookup (cons (integer->char c) '()) a)
-                                      (cons (read-word (read-byte) w a) '()))
+                   ((eq? (peek-byte) 44)
+                    (read-byte)
+                    (cond ((eq? (peek-byte) 64)
+                           (read-byte)
+                           (cons (lookup (symbol->list (quote unsyntax-splicing)) a)
+                                 (cons (read-word (read-byte) w a) (list))))
+                          (else
+                           (cons (lookup (symbol->list (quote unsyntax)) a)
+                                 (cons (read-word (read-byte) w a) (list))))))
+                   ((eq? (peek-byte) 39) (read-byte)
+                    (cons (lookup (cons (integer->char 35) (cons (integer->char 39) (list))) a)
+                          (cons (read-word (read-byte) w a) (list))))
+                   ((eq? (peek-byte) 96) (read-byte)
+                    (cons (lookup (cons (integer->char 35) (cons (integer->char 96) (list))) a)
+                          (cons (read-word (read-byte) w a) (list))))
+                   (else (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
+      ((eq? c 39) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
+                                      (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))))
                       (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) (cons (lookup (cons (integer->char c) '()) a)
-                                      (cons (read-word (read-byte) w a) '()))
+      ((eq? c 41) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
+                                      (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
                       (begin (unread-byte c) (lookup w a))))
       ((eq? c 44) (cond
                    ((eq? (peek-byte) 64) (begin (read-byte)
                                                 (cons

-                                                 (lookup (symbol->list 'unquote-splicing) a)
-                                                 (cons (read-word (read-byte) w a) '()))))
+                                                 (lookup (symbol->list (quote unquote-splicing)) a)
+                                                 (cons (read-word (read-byte) w a) (list)))))

                    (else  (cons (lookup-char c a) (cons (read-word (read-byte) w a)
                    (else  (cons (lookup-char c a) (cons (read-word (read-byte) w a)

-                                                        '())))))
-      ((eq? c 96) (cons (lookup-char c a) (cons (read-word (read-byte) w a) '())))
+                                                        (list))))))
+      ((eq? c 96) (cons (lookup-char c a) (cons (read-word (read-byte) w a) (list))))

       ((eq? c 59) (read-line-comment c) (read-word 10 w a))
       ((eq? c 59) (read-line-comment c) (read-word 10 w a))

-      (else (read-word (read-byte) (append w (cons (integer->char c) '())) a))))
+      (else (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))

 
   ((lambda (p)
 
   ((lambda (p)

-     ;;(display 'program=) (display p) (newline)
+     ;;(display (quote scheme-program=)) (display p) (newline)

      (begin-env p (current-module)))
    (read-input-file)))
      (begin-env p (current-module)))
    (read-input-file)))

diff --git a/module/mes/repl.mes b/module/mes/repl.mes
index 2ec4f1f795fc513b996c61f8b79a1c0eb1e36edc..ab220fab8867955f9c28c4b54a7b53c3d5083b18 100644 (file)
--- a/module/mes/repl.mes
+++ b/module/mes/repl.mes
@@ -114,7 +114,7 @@ along with Mes.  If not, see <http://www.gnu.org/licenses/>.
         (print-sexp? #t))
     
     (define (expand)
         (print-sexp? #t))
     
     (define (expand)

-      (let ((sexp (read-env (current-module))))
+      (let ((sexp (read)))

         (when #t print-sexp?
               (display "[sexp=")
               (display sexp)
         (when #t print-sexp?
               (display "[sexp=")
               (display sexp)


@@ -124,7 +124,7 @@ along with Mes.  If not, see <http://www.gnu.org/licenses/>.
         (newline)))
 
     (define (scexpand)
         (newline)))
 
     (define (scexpand)

-      (let ((sexp (read-env (current-module))))
+      (let ((sexp (read)))

         (when #t print-sexp?
               (display "[sexp=")
               (display sexp)
         (when #t print-sexp?
               (display "[sexp=")
               (display sexp)


@@ -142,7 +142,7 @@ along with Mes.  If not, see <http://www.gnu.org/licenses/>.
         (display (assoc-ref topic-alist topic))))
     (define (use a)
       (lambda ()
         (display (assoc-ref topic-alist topic))))
     (define (use a)
       (lambda ()

-        (let ((module (read-env (current-module))))
+        (let ((module (read)))

           (mes-load-module-env module a))))
     (define (meta command a)
       (let ((command-alist `((expand . ,expand)
           (mes-load-module-env module a))))
     (define (meta command a)
       (let ((command-alist `((expand . ,expand)

diff --git a/reader.c b/reader.c
index f82ff649ec99cf75f4570515701bd22fe964e52c..46f293a23a4aeb43aadfab6b6d511d456b92de02 100644 (file)
--- a/reader.c
+++ b/reader.c
@@ -36,13 +36,13 @@ unread_char (SCM c)
   return ungetchar (VALUE (c));
 }
 
   return ungetchar (VALUE (c));
 }
 

-SCM
-unget_char (SCM c)
+int
+read_block_comment (int c)

 {
 {

-  assert (TYPE (c) == NUMBER || TYPE (c) == CHAR);
-  ungetchar (VALUE (c));
-  return c;
+  if (c == '!' && peekchar () == '#') return getchar ();
+  return read_block_comment (getchar ());

 }
 }

+

 int
 read_line_comment (int c)
 {
 int
 read_line_comment (int c)
 {


@@ -50,12 +50,6 @@ read_line_comment (int c)
   return read_line_comment (getchar ());
 }
 
   return read_line_comment (getchar ());
 }
 

-int
-read_block_comment (int c)
-{
-  if (c == '!' && peekchar () == '#') return getchar ();
-  return read_block_comment (getchar ());
-}

 
 SCM lookup_char (int c, SCM a);
 
 
 SCM lookup_char (int c, SCM a);
 


@@ -67,12 +61,14 @@ read_word (int c, SCM w, SCM a)
   if (c == '\n' && VALUE (car (w)) == '.' && cdr (w) == cell_nil) return cell_dot;
   if (c == EOF || c == '\n') return lookup (w, a);
   if (c == ' ') return read_word ('\n', w, a);
   if (c == '\n' && VALUE (car (w)) == '.' && cdr (w) == cell_nil) return cell_dot;
   if (c == EOF || c == '\n') return lookup (w, a);
   if (c == ' ') return read_word ('\n', w, a);

-  if (c == '"' && w == cell_nil) return read_string ();
-  if (c == '"') {ungetchar (c); return lookup (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 == '(' && 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);}
+#if READER
+  if (c == '"' && w == cell_nil) return read_string ();
+  if (c == '"') {ungetchar (c); return lookup (w, a);}

   if (c == ',' && peekchar () == '@') {getchar (); return cons (lookup (STRING (cell_symbol_unquote_splicing), a),
                                                                    cons (read_word (getchar (), w, a),
                                                                          cell_nil));}
   if (c == ',' && peekchar () == '@') {getchar (); return cons (lookup (STRING (cell_symbol_unquote_splicing), a),
                                                                    cons (read_word (getchar (), w, a),
                                                                          cell_nil));}


@@ -93,11 +89,11 @@ read_word (int c, SCM w, SCM a)
     c = getchar ();
     return cons (lookup (cons (make_char ('#'), cons (make_char (c), cell_nil)), a),
                  cons (read_word (getchar (), w, a), cell_nil));}
     c = getchar ();
     return cons (lookup (cons (make_char ('#'), cons (make_char (c), cell_nil)), a),
                  cons (read_word (getchar (), w, a), cell_nil));}

-  if (c == ';') {read_line_comment (c); return read_word ('\n', w, a);}

   if (c == '#' && peekchar () == 'x') {getchar (); return read_hex ();}
   if (c == '#' && peekchar () == '\\') {getchar (); return read_character ();}
   if (c == '#' && w == cell_nil && peekchar () == '(') {getchar (); return list_to_vector (read_list (a));}
   if (c == '#' && peekchar () == '!') {getchar (); read_block_comment (getchar ()); return read_word (getchar (), w, a);}
   if (c == '#' && peekchar () == 'x') {getchar (); return read_hex ();}
   if (c == '#' && peekchar () == '\\') {getchar (); return read_character ();}
   if (c == '#' && w == cell_nil && peekchar () == '(') {getchar (); return list_to_vector (read_list (a));}
   if (c == '#' && peekchar () == '!') {getchar (); read_block_comment (getchar ()); return read_word (getchar (), w, a);}

+#endif //READER

   return read_word (getchar (), append2 (w, cons (make_char (c), cell_nil)), a);
 }
 
   return read_word (getchar (), append2 (w, cons (make_char (c), cell_nil)), a);
 }
 


@@ -183,7 +179,9 @@ eat_whitespace (int c)
 {
   while (c == ' ' || c == '\t' || c == '\n') c = getchar ();
   if (c == ';') return eat_whitespace (read_line_comment (c));
 {
   while (c == ' ' || c == '\t' || c == '\n') c = getchar ();
   if (c == ';') return eat_whitespace (read_line_comment (c));

+#if READER

   if (c == '#' && peekchar () == '!') {getchar (); read_block_comment (getchar ()); return eat_whitespace (getchar ());}
   if (c == '#' && peekchar () == '!') {getchar (); read_block_comment (getchar ()); return eat_whitespace (getchar ());}

+#endif

   return c;
 }
 
   return c;
 }