core: Quoted internals are symbols.

* mes.c (begin_env): Rename from begin.  Update callers.
  (scm_begin, scm_if, scm_define, scm_set_x): Rename from symbol_*.
  (symbol_begin, symbol_define, symbol_if, scm_lambda, scm_set_x): New symbols.
  (mes_environment): Add them to environment, SYMBOL->SCM.
* define.c (define_env): Rename from define.  Update callers.
* build-aux/mes-snarf.scm: Shadow internals (SCM) by their symbol.
This commit is contained in:
Jan Nieuwenhuizen 2016-11-02 10:26:04 +01:00
parent 8a13b472e3
commit c851935d4d
4 changed files with 22 additions and 18 deletions

View file

@ -80,7 +80,8 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
(format #f "scm ~a = {FUNCTION~a, .name=~S, .function~a=&~a};\n" (function-builtin-name f) n (function-scm-name f) n (.name f))))) (format #f "scm ~a = {FUNCTION~a, .name=~S, .function~a=&~a};\n" (function-builtin-name f) n (function-scm-name f) n (.name f)))))
(define (snarf-symbols string) (define (snarf-symbols string)
(let* ((matches (list-matches "\nscm ([a-z_0-9]+) = [{](SCM|SYMBOL)," string))) (let* ((matches (append (list-matches "\nscm ([a-z_0-9]+) = [{](SCM)," string)
(list-matches "\nscm ([a-z_0-9]+) = [{](SYMBOL)," string))))
(map (cut match:substring <> 1) matches))) (map (cut match:substring <> 1) matches)))
(define (snarf-functions string) (define (snarf-functions string)

View file

@ -20,7 +20,7 @@
#if !BOOT #if !BOOT
scm * scm *
define (scm *x, scm *a) define_env (scm *x, scm *a)
{ {
scm *e; scm *e;
scm *name = cadr (x); scm *name = cadr (x);
@ -43,7 +43,7 @@ define (scm *x, scm *a)
return entry; return entry;
} }
#else // BOOT #else // BOOT
scm*define (scm *x, scm *a){} scm*define_env (scm *x, scm *a){}
#endif #endif
scm * scm *

32
mes.c
View file

@ -86,13 +86,14 @@ scm scm_circular = {SCM, "*circular*"};
scm scm_label = { scm scm_label = {
SCM, "label"}; SCM, "label"};
#endif #endif
scm scm_lambda = {SCM, "lambda"}; scm scm_begin = {SCM, "begin"};
scm symbol_begin = {SCM, "begin"}; scm symbol_lambda = {SYMBOL, "lambda"};
scm symbol_if = {SCM, "if"}; scm symbol_begin = {SYMBOL, "begin"};
scm symbol_define = {SCM, "define"}; scm symbol_if = {SYMBOL, "if"};
scm symbol_define = {SYMBOL, "define"};
scm symbol_define_macro = {SCM, "define-macro"}; scm symbol_define_macro = {SCM, "define-macro"};
scm symbol_set_x = {SCM, "set!"}; scm symbol_set_x = {SYMBOL, "set!"};
scm symbol_quote = {SYMBOL, "quote"}; scm symbol_quote = {SYMBOL, "quote"};
scm symbol_quasiquote = {SYMBOL, "quasiquote"}; scm symbol_quasiquote = {SYMBOL, "quasiquote"};
@ -359,10 +360,10 @@ apply_env (scm *fn, scm *x, scm *a)
return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil))); return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil)));
if (fn == &symbol_current_module) return a; if (fn == &symbol_current_module) return a;
} }
else if (fn->car == &scm_lambda) { else if (fn->car == &symbol_lambda) {
scm *p = pairlis (cadr (fn), x, a); scm *p = pairlis (cadr (fn), x, a);
cache_invalidate_range (p, a->cdr); cache_invalidate_range (p, a->cdr);
scm *r = begin (cddr (fn), cons (cons (&scm_closure, p), p)); scm *r = begin_env (cddr (fn), cons (cons (&scm_closure, p), p));
cache_invalidate_range (p, a->cdr); cache_invalidate_range (p, a->cdr);
return r; return r;
} }
@ -373,7 +374,7 @@ apply_env (scm *fn, scm *x, scm *a)
a = cdr (a); a = cdr (a);
scm *p = pairlis (args, x, a); scm *p = pairlis (args, x, a);
cache_invalidate_range (p, a->cdr); cache_invalidate_range (p, a->cdr);
scm *r = begin (body, cons (cons (&scm_closure, p), p)); scm *r = begin_env (body, cons (cons (&scm_closure, p), p));
cache_invalidate_range (p, a->cdr); cache_invalidate_range (p, a->cdr);
return r; return r;
} }
@ -422,8 +423,8 @@ builtin_eval (scm *e, scm *a)
return e; return e;
#endif #endif
if (e->car == &symbol_begin) if (e->car == &symbol_begin)
return begin (e, a); return begin_env (e, a);
if (e->car == &scm_lambda) if (e->car == &symbol_lambda)
return make_closure (cadr (e), cddr (e), assq (&scm_closure, a)); return make_closure (cadr (e), cddr (e), assq (&scm_closure, a));
if (e->car == &scm_closure) if (e->car == &scm_closure)
return e; return e;
@ -431,9 +432,9 @@ builtin_eval (scm *e, scm *a)
return builtin_if (cdr (e), a); return builtin_if (cdr (e), a);
#if !BOOT #if !BOOT
if (e->car == &symbol_define) if (e->car == &symbol_define)
return define (e, a); return define_env (e, a);
if (e->car == &symbol_define_macro) if (e->car == &symbol_define_macro)
return define (e, a); return define_env (e, a);
#else #else
if (e->car == &symbol_define) { if (e->car == &symbol_define) {
fprintf (stderr, "C DEFINE: "); fprintf (stderr, "C DEFINE: ");
@ -496,7 +497,7 @@ sc_expand_env (scm *e, scm *a)
} }
scm * scm *
begin (scm *e, scm *a) begin_env (scm *e, scm *a)
{ {
scm *r = &scm_unspecified; scm *r = &scm_unspecified;
while (e != &scm_nil) { while (e != &scm_nil) {
@ -1106,6 +1107,7 @@ mes_environment () ///((internal))
symbols = cons (&scm_label, symbols); symbols = cons (&scm_label, symbols);
a = cons (cons (&scm_label, &scm_t), a); a = cons (cons (&scm_label, &scm_t), a);
#endif #endif
a = cons (cons (&symbol_begin, &scm_begin), a);
#include "string.environment.i" #include "string.environment.i"
#include "math.environment.i" #include "math.environment.i"
@ -1123,7 +1125,7 @@ mes_environment () ///((internal))
scm * scm *
make_lambda (scm *args, scm *body) make_lambda (scm *args, scm *body)
{ {
return cons (&scm_lambda, cons (args, body)); return cons (&symbol_lambda, cons (args, body));
} }
scm * scm *
@ -1151,7 +1153,7 @@ read_file_env (scm *e, scm *a)
scm * scm *
load_file_env (scm *a) load_file_env (scm *a)
{ {
return begin (read_file_env (read_env (a), a), a); return begin_env (read_file_env (read_env (a), a), a);
} }
#include "type.c" #include "type.c"

View file

@ -34,6 +34,7 @@ exit $?
(pass-if "begin" (seq? (begin 'a 'b (+ 1 2)) 3)) (pass-if "begin" (seq? (begin 'a 'b (+ 1 2)) 3))
(pass-if "lambda" (symbol? 'lambda))
(begin (define *top-begin-a* '*top-begin-a*)) (begin (define *top-begin-a* '*top-begin-a*))
(pass-if "top begin " (seq? *top-begin-a* '*top-begin-a*)) (pass-if "top begin " (seq? *top-begin-a* '*top-begin-a*))