core: Simplify lookup.

* reader.c (lookup_): Rename from lookup.  Remove all lookups except
  for numbers and symbols.  Update callers.
* mes.c (make_symbol_): Rename from internal_make_symbol.  Update
  callers.
* module/mes/read-0.mes (lookup): New function.
  (read-word): Remove all lookup calls, except for numbers and symbols.

diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm
index 1b962060423b5edc379e3ac1ea47b592433e5250..53c21f147e1936ed4ce60b21a5e597f1c4f25aa4 100755 (executable)
--- a/build-aux/mes-snarf.scm
+++ b/build-aux/mes-snarf.scm
@@ -51,16 +51,18 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
 
 (define (function-scm-name f)
   (or (assoc-ref (.annotation f) 'name)
-      ((compose
-        (regexp-replace "_" "-")
-        (regexp-replace "_" "-")
-        (regexp-replace "_" "-")
-        (regexp-replace "_" "-")
-        (regexp-replace "^builtin_" "")
-        (regexp-replace "_to_" "->")
-        (regexp-replace "_x$" "!")
-        (regexp-replace "_p$" "?"))
-       (.name f))))
+      (let ((name ((compose
+                    (regexp-replace "_" "-")
+                    (regexp-replace "_" "-")
+                    (regexp-replace "_" "-")
+                    (regexp-replace "_" "-")
+                    (regexp-replace "^builtin_" "")
+                    (regexp-replace "_to_" "->")
+                    (regexp-replace "_x$" "!")
+                    (regexp-replace "_p$" "?"))
+                   (.name f))))
+        (if (not (string-suffix? "-" name)) name
+            (string-append "core:" (string-drop-right name 1))))))
 
 (define %builtin-prefix% "scm_")
 (define (function-builtin-name f)

diff --git a/mes.c b/mes.c
index 722db4f08951a8705ba44987de8e0a7e0c8ccfe7..b4b1ec7c0de0f9613f3da83bbeccb05426efae2c 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -32,7 +32,6 @@
 #define FIXED_PRIMITIVES 1
 
 int ARENA_SIZE = 100000;
-
 int MAX_ARENA_SIZE = 20000000;
 int GC_SAFETY = 100;
 
@@ -697,8 +696,8 @@ make_function (SCM name, SCM id, SCM arity)
 SCM
 make_keyword (SCM s)
 {
-  SCM x = internal_lookup_symbol (s);
-  x = x ? x : internal_make_symbol (s);
+  SCM x = lookup_symbol_ (s);
+  x = x ? x : make_symbol_ (s);
   g_cells[tmp_num].value = KEYWORD;
   return make_cell (tmp_num, STRING (x), 0);
 }
@@ -749,7 +748,7 @@ null_p (SCM x)
 }
 
 SCM
-internal_make_symbol (SCM s)
+make_symbol_ (SCM s)
 {
   g_cells[tmp_num].value = SYMBOL;
   SCM x = make_cell (tmp_num, s, 0);
@@ -760,8 +759,8 @@ internal_make_symbol (SCM s)
 SCM
 make_symbol (SCM s)
 {
-  SCM x = internal_lookup_symbol (s);
-  return x ? x : internal_make_symbol (s);
+  SCM x = lookup_symbol_ (s);
+  return x ? x : make_symbol_ (s);
 }
 
 SCM

diff --git a/module/mes/read-0.mes b/module/mes/read-0.mes
index 6e4a267e35d14350c0f3faf42ef91019a23a78c1..b3895577a02ea7376d488b51e51f9736dfa45140 100644 (file)
--- a/module/mes/read-0.mes
+++ b/module/mes/read-0.mes
@@ -245,11 +245,17 @@
        ((eq? c -1) (display (quote EOF-in-string)) (newline) (exit 1))
        (#t (read-string (read-byte) (peek-byte) (append-char s c)))))
     (list->string (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)
+    (core:lookup (map1 integer->char 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 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))
@@ -269,40 +275,41 @@
                    (read-byte)
                    (cond ((eq? (peek-byte) 64)
                           (read-byte)
-                          (cons (lookup (symbol->list (quote unsyntax-splicing)) a)
+                          (cons (quote unsyntax-splicing)
                                 (cons (read-word (read-byte) w a) (list))))
                          (#t
-                          (cons (lookup (symbol->list (quote unsyntax)) a)
+                          (cons (quote unsyntax)
                                 (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))))
+                   (cons (quote syntax) (cons (read-word (read-byte) w a) (list))))
+                  ((eq? (peek-byte) 58) (read-byte)
+                   (make-keyword (symbol->list (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 (lookup (cons (integer->char 35) (cons (integer->char 96) (list))) a)
+                   (cons (quote quasisyntax)
                          (cons (read-word (read-byte) w a) (list))))
-                  (#t (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)
+                  (#t (read-word (read-byte) (append2 w (cons c (list))) 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) (cons (lookup (cons (integer->char c) (list)) a)
-                                     (cons (read-word (read-byte) w a) (list)))
+     ((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
-                                                (lookup (symbol->list (quote unquote-splicing)) a)
-                                                (cons (read-word (read-byte) w a) (list)))))
-                  (#t (cons (quote unquote) (cons (read-word (read-byte) w a)
-                                                      (list))))))
+                  ((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 -1) (list))
-     (#t (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
+     (#t (read-word (read-byte) (append2 w (cons c (list))) a))))
 
   ((lambda (p)
      (begin-env p (current-module)))

diff --git a/reader.c b/reader.c
index 6ff8ffd9006bc88290d8f464bc1a45ce4b13b6a2..a585d91676ed56504ff52c3cc1c27c8429c39030 100644 (file)
--- a/reader.c
+++ b/reader.c
@@ -51,12 +51,12 @@ read_word (int c, SCM w, SCM 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 == EOF || c == '\n') return lookup (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 == '(') {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 == ')') {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);
 }
@@ -88,7 +88,7 @@ read_env (SCM a)
 }
 
 SCM
-lookup (SCM s, SCM a)
+lookup_ (SCM s, SCM a)
 {
   if (isdigit (VALUE (car (s))) || (VALUE (car (s)) == '-' && cdr (s) != cell_nil)) {
     SCM p = s;
@@ -106,31 +106,8 @@ lookup (SCM s, SCM a)
     if (p == cell_nil) return make_number (n * sign);
   }
 
-  if (VALUE (car (s)) == '#' && VALUE (cadr (s)) == ':') return make_keyword (cddr (s));
-
-  SCM x = internal_lookup_symbol (s);
-  if (x) return x;
-
-  if (cdr (s) == cell_nil) {
-    if (VALUE (car (s)) == '\'') return cell_symbol_quote;
-    if (VALUE (car (s)) == '`') return cell_symbol_quasiquote;
-    if (VALUE (car (s)) == ',') return cell_symbol_unquote;
-  }
-  else if (cddr (s) == cell_nil) {
-    if (VALUE (car (s)) == ',' && VALUE (cadr (s)) == '@') return cell_symbol_unquote_splicing;
-    if (VALUE (car (s)) == '#' && VALUE (cadr (s)) == '\'') return cell_symbol_syntax;
-    if (VALUE (car (s)) == '#' && VALUE (cadr (s)) == '`') return cell_symbol_quasisyntax;
-    if (VALUE (car (s)) == '#' && VALUE (cadr (s)) == ',') return cell_symbol_unsyntax;
-  }
-  else if (cdddr (s) == cell_nil) {
-    if (VALUE (car (s)) == '#' && VALUE (cadr (s)) == ',' && VALUE (caddr (s)) == '@') return cell_symbol_unsyntax_splicing;
-        if (VALUE (car (s)) == 'E' && VALUE (cadr (s)) == 'O' && VALUE (caddr (s)) == 'F') {
-      fprintf (stderr, "mes: got EOF\n");
-      return cell_nil; // `EOF': eval program, which may read stdin
-    }
-  }
-
-  return internal_make_symbol (s);
+  SCM x = lookup_symbol_ (s);
+  return x ? x : make_symbol_ (s);
 }
 
 SCM
@@ -146,7 +123,7 @@ list_of_char_equal_p (SCM a, SCM b)
 }
 
 SCM
-internal_lookup_symbol (SCM s)
+lookup_symbol_ (SCM s)
 {
   SCM x = g_symbols;
   while (x) {