diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm index 1b962060..53c21f14 100755 --- 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 722db4f0..b4b1ec7c 100644 --- 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 6e4a267e..b3895577 100644 --- 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 6ff8ffd9..a585d916 100644 --- 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) {