artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

core: Simplify lookup.

Browse source 
* 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.
This commit is contained in:
Jan Nieuwenhuizen 2016-12-23 11:31:34 +01:00
parent 6f60e12d76
commit 18ba10e2ae
4 changed files with 50 additions and 65 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
build-aux/mes-snarf.scm
View file

@ -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)

11
mes.c
View file

@ -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

45
module/mes/read-0.mes
View file

@ -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)))

37
reader.c
View file

@ -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) {