mes: Single environment lookup for variables, SICP chapter 3.

* src/mes.c (t): Add TVARIABLE.
  (scm_vm_eval_deref): New vm special.
  (make_vref_): New internal function.
  (eval_apply): WIP: replace symbols with their variable reference.
* src/gc.c (gc_loop): Handle TVARIABLE.
* src/lib.c (display_helper): Handle TVARIABLE.
* module/mes/type-0.mes (<cell:variable>): New variable.
  (cell:type-alist): Add it.
  (variable?): New function.
* module/mes/display.mes (display): Handle <variable>.
This commit is contained in:
Jan Nieuwenhuizen 2017-12-09 08:33:50 +01:00
parent d1444ead65
commit 9fc27ee25a
15 changed files with 367 additions and 156 deletions

View file

@ -434,9 +434,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
(add-target (snarf "src/vector.c" #:mes? #t))))
(add-target (bin.gcc "src/mes.c" #:dependencies gcc-snarf-targets
#:defines `("MES_FIXED_PRIMITIVES=1"
"MES_FULL=1"
"POSIX=1"
#:defines `("POSIX=1"
,(string-append "VERSION=\"" %version "\"")
,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"")
,(string-append "PREFIX=\"" %prefix "\""))
@ -444,17 +442,13 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
(add-target (bin.gcc "src/mes.c" #:libc libc-gcc.mlibc-o
#:dependencies mes-snarf-targets
#:defines `( "MES_FIXED_PRIMITIVES=1"
"MES_FULL=1"
,(string-append "VERSION=\"" %version "\"")
#:defines `(,(string-append "VERSION=\"" %version "\"")
,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") "/" %moduledir "/") "\"")
,(string-append "PREFIX=\"" %prefix "\""))
#:includes '("src")))
(add-target (bin.mescc "src/mes.c" #:dependencies mes-snarf-targets
#:defines `("MES_FIXED_PRIMITIVES=1"
"MES_FULL=1"
,(string-append "VERSION=\"" %version "\"")
#:defines `(,(string-append "VERSION=\"" %version "\"")
,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"")
,(string-append "PREFIX=\"" %prefix "\""))
#:includes '("src")))

View file

@ -1223,8 +1223,8 @@
(info (append-text info (wrap-as `((#:label ,skip-b-label))))))
info))
((cast ,cast ,o)
((expr->accu info) o))
((cast ,type ,expr)
((expr->accu info) expr))
((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
(let* ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b)))

View file

@ -75,7 +75,9 @@
(if (null? lst) (list)
(cons (f (car lst)) (map1 f (cdr lst)))))
(define map map1)
(define (map f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map f (cdr lst)))))
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
@ -104,6 +106,7 @@
(list (quote if) (quote r) (quote r)
(cons (quote or) (cdr x))))
(car x)))))
(define-macro (module-define! module name value)
;;(list 'define name value)
#t)

View file

@ -95,6 +95,12 @@
(display "#<macro " port)
(display (core:cdr x) port)
(display ">" port))
((variable? x)
(display "#<variable " port)
(if (variable-global? x)
(display "*global* " port))
(display (car (core:car x)) port)
(display ">" port))
((number? x)
(display (number->string x) port))
((pair? x)

View file

@ -35,12 +35,16 @@
core:write-error
core:write-port
core:type
pmatch-car
pmatch-cdr
)
;;#:re-export (open-input-file open-input-string with-input-from-string)
)
(cond-expand
(guile
(define pmatch-car car)
(define pmatch-cdr cdr)
(define core:exit exit)
(define core:display display)
(define core:display-port display)

View file

@ -26,15 +26,6 @@
(string-append (string-join (map symbol->string o) "/") ".mes"))
(define *modules* '(mes/base-0.mes))
(define (mes-load-module-env module a)
(push! *input-ports* (current-input-port))
(set-current-input-port (open-input-file (string-append %moduledir (module->file module))))
(let ((x (core:eval (append2 (cons 'begin (read-input-file-env a))
'((current-module)))
a)))
(set-current-input-port (pop! *input-ports*))
x))
(define-macro (mes-use-module module)
(list 'if (list not (list memq (list string->symbol (module->file module)) '*modules*))
(list
@ -46,3 +37,28 @@
(list core:display-error ";;; already loaded: ")
(list core:display-error (list 'quote module))
(list core:display-error "\n")))))
(define *input-ports* '())
(define-macro (push! stack o)
(cons
'begin
(list
(list 'set! stack (list cons o stack))
stack)))
(define-macro (pop! stack)
(list 'let (list (list 'o (list car stack)))
(list 'set! stack (list cdr stack))
'o))
(define (mes-load-module-env module a)
(push! *input-ports* (current-input-port))
(set-current-input-port (open-input-file (string-append %moduledir (module->file module))))
(let ((x (core:eval (append2 (cons 'begin (read-input-file-env a))
'((current-module)))
a)))
(set-current-input-port (pop! *input-ports*))
x))
(define (mes-load-module-env module a)
(core:display-error "loading:") (core:write-error (string-append %moduledir (module->file module))) (core:display-error "\n")
(primitive-load (string-append %moduledir (module->file module)))
(core:display-error "dun\n")
)

View file

@ -3,6 +3,7 @@
;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc
;;; Copyright (C) 2005,2006,2007 Oleg Kiselyov
;;; Copyright (C) 2007 Daniel P. Friedman
;;; Copyright (C) 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@ -51,20 +52,17 @@
(define-module (system base pmatch)
#:export-syntax (pmatch))
(define-syntax-rule (pmatch e cs ...)
(let ((v e)) (pmatch1 v cs ...)))
(define-syntax pmatch1
(define-syntax pmatch
(syntax-rules (else guard)
((_ v) (if #f #f))
((_ v (else e0 e ...)) (let () e0 e ...))
((_ v (pat (guard g ...) e0 e ...) cs ...)
(let ((fk (lambda () (pmatch1 v cs ...))))
(let ((fk (lambda () (pmatch v cs ...))))
(ppat v pat
(if (and g ...) (let () e0 e ...) (fk))
(fk))))
((_ v (pat e0 e ...) cs ...)
(let ((fk (lambda () (pmatch1 v cs ...))))
(let ((fk (lambda () (pmatch v cs ...))))
(ppat v pat (let () e0 e ...) (fk))))))
(define-syntax ppat
@ -76,8 +74,6 @@
((_ v (unquote var) kt kf) (let ((var v)) kt))
((_ v (x . y) kt kf)
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
;;(ppat vx x (ppat vy y kt kf) kf) ;; FIXME: broken with syntax.scm
(ppat (car v) x (ppat (cdr v) y kt kf) kf))
(ppat (pmatch-car v) x (ppat (pmatch-cdr v) y kt kf) kf)
kf))
((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))

View file

@ -27,5 +27,6 @@
(define datum->syntax datum->syntax-object)
(define syntax->datum syntax-object->datum)
(define-macro (portable-macro-expand) #t)
(set! macro-expand sc-expand)

View file

@ -38,8 +38,9 @@
(define <cell:string> 10)
(define <cell:symbol> 11)
(define <cell:values> 12)
(define <cell:vector> 13)
(define <cell:broken-heart> 14)
(define <cell:variable> 13)
(define <cell:vector> 14)
(define <cell:broken-heart> 15)
(define cell:type-alist
(list (cons <cell:char> (quote <cell:char>))
@ -55,6 +56,7 @@
(cons <cell:string> (quote <cell:string>))
(cons <cell:symbol> (quote <cell:symbol>))
(cons <cell:values> (quote <cell:values>))
(cons <cell:variable> (quote <cell:variable>))
(cons <cell:vector> (quote <cell:vector>))
(cons <cell:broken-heart> (quote <cell:broken-heart>))))
@ -104,10 +106,15 @@
(define (symbol? x)
(eq? (core:type x) <cell:symbol>))
;; Hmm?
(define (values? x)
(eq? (core:type x) <cell:values>))
(define (variable? x)
(eq? (core:type x) <cell:variable>))
(define (variable-global? x)
(core:cdr x))
(define (vector? x)
(eq? (core:type x) <cell:vector>))

View file

@ -111,4 +111,4 @@
(core:display-error module->file) (core:display-error "\n")
(define %moduledir (string-append (getcwd) "/"))
(mes-use-module (scaffold boot data module))
(mes-use-module (scaffold boot data module))
;; (mes-use-module (scaffold boot data module))

View file

@ -102,7 +102,8 @@ gc_loop (SCM scan) ///((internal))
|| scan == 1 // null
|| NTYPE (scan) == TSPECIAL
|| NTYPE (scan) == TSTRING
|| NTYPE (scan) == TSYMBOL)
|| NTYPE (scan) == TSYMBOL
|| NTYPE (scan) == TVARIABLE)
{
SCM car = gc_copy (g_news[scan].car);
gc_relocate_car (scan, car);
@ -111,7 +112,8 @@ gc_loop (SCM scan) ///((internal))
|| NTYPE (scan) == TCONTINUATION
|| NTYPE (scan) == TMACRO
|| NTYPE (scan) == TPAIR
|| NTYPE (scan) == TVALUES)
|| NTYPE (scan) == TVALUES
|| NTYPE (scan) == TVARIABLE)
&& g_news[scan].cdr) // allow for 0 terminated list of symbols
{
SCM cdr = gc_copy (g_news[scan].cdr);
@ -133,7 +135,8 @@ gc_check ()
SCM
gc ()
{
if (g_debug == 1) eputs (".");
if (g_debug == 1)
eputs (".");
if (g_debug > 1)
{
eputs (";;; gc[");
@ -143,11 +146,13 @@ gc ()
eputs ("]...");
}
g_free = 1;
if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena ();
if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE)
gc_up_arena ();
for (int i=g_free; i<g_symbol_max; i++)
gc_copy (i);
make_tmps (g_news);
g_symbols = gc_copy (g_symbols);
g_macros = gc_copy (g_macros);
SCM new = gc_copy (g_stack);
if (g_debug > 1)
{

View file

@ -56,7 +56,7 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
case TCLOSURE:
{
fputs ("#<closure ", fd);
display_helper (CDR (x), cont, "", fd, 0);
//display_helper (CDR (x), cont, "", fd, 0);
fputs (">", fd);
break;
}
@ -81,6 +81,15 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
fputs (">", fd);
break;
}
case TVARIABLE:
{
fputs ("#<variable ", fd);
if (VARIABLE_GLOBAL_P (x) == cell_t)
fputs ("*global* ", fd);
display_helper (CAR (VARIABLE (x)), cont, "", fd, 0);
fputs (">", fd);
break;
}
case TNUMBER:
{
fputs (itoa (VALUE (x)), fd);
@ -89,6 +98,12 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
case TPAIR:
{
if (!cont) fputs ("(", fd);
if (CAR (x) == cell_closure)
fputs ("*closure* ", fd);
else
if (CAAR (x) == cell_closure)
fputs ("(*closure* ...) ", fd);
else
if (CAR (x) == cell_circular)
{
fputs ("(*circ* . ", fd);
@ -97,8 +112,8 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
while (x != cell_nil && i++ < 10)
{
g_depth = 1;
//display_helper (CAAR (x), 0, "", fd, write_p); fputs (" ", fd);
fdisplay_ (CAAR (x), fd, write_p); fputs (" ", fd);
display_helper (CAAR (x), 0, "", fd, write_p); fputs (" ", fd);
//fdisplay_ (CAAR (x), fd, write_p); fputs (" ", fd);
x = CDR (x);
}
fputs (" ...)", fd);

330
src/mes.c
View file

@ -32,7 +32,7 @@ int MAX_ARENA_SIZE = 80000000; // 32b: ~1GiB
int MAX_ARENA_SIZE = 200000000; // 32b: 2GiB, 64b: 4GiB
#endif
int GC_SAFETY = 250;
int GC_SAFETY = 2000;
char *g_arena = 0;
typedef int SCM;
@ -51,8 +51,11 @@ SCM r1 = 0;
SCM r2 = 0;
// continuation
SCM r3 = 0;
// macro
SCM g_macros = 1; // cell_nil
enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART};
enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
#if !_POSIX_SOURCE
struct scm {
@ -86,9 +89,10 @@ struct scm {
enum type_t type;
union {
char const* name;
SCM string;
SCM car;
SCM ref;
SCM string;
SCM variable;
int length;
};
union {
@ -97,6 +101,7 @@ struct scm {
SCM cdr;
SCM closure;
SCM continuation;
SCM global_p;
SCM macro;
SCM vector;
int hits;
@ -145,6 +150,7 @@ struct scm scm_symbol_set_x = {TSYMBOL, "set!",0};
struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0};
struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-expand",0};
struct scm scm_symbol_portable_macro_expand = {TSYMBOL, "portable-macro-expand",0};
struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0};
struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0};
@ -170,9 +176,8 @@ struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
struct scm scm_symbol_car = {TSYMBOL, "car",0};
struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0};
struct scm scm_symbol_null_p = {TSYMBOL, "null?",0};
struct scm scm_symbol_eq_p = {TSYMBOL, "eq?",0};
struct scm scm_symbol_cons = {TSYMBOL, "cons",0};
struct scm scm_symbol_pmatch_car = {TSYMBOL, "pmatch-car",0};
struct scm scm_symbol_pmatch_cdr = {TSYMBOL, "pmatch-cdr",0};
struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0};
struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",0};
@ -181,11 +186,8 @@ struct scm scm_vm_apply = {TSPECIAL, "core:apply",0};
struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0};
struct scm scm_vm_eval = {TSPECIAL, "core:eval",0};
//MES_FIXED_PRIMITIVES
struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",0};
struct scm scm_vm_eval_cdr = {TSPECIAL, "*vm-eval-cdr*",0};
struct scm scm_vm_eval_cons = {TSPECIAL, "*vm-eval-cons*",0};
struct scm scm_vm_eval_null_p = {TSPECIAL, "*vm-eval-null-p*",0};
struct scm scm_vm_eval_pmatch_car = {TSPECIAL, "*vm-eval-pmatch-car*",0};
struct scm scm_vm_eval_pmatch_cdr = {TSPECIAL, "*vm-eval-pmatch-cdr*",0};
struct scm scm_vm_eval_define = {TSPECIAL, "*vm-eval-define*",0};
struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0};
@ -262,11 +264,14 @@ int g_function = 0;
#define LENGTH(x) g_cells[x].car
#define REF(x) g_cells[x].car
#define STRING(x) g_cells[x].car
#define VARIABLE(x) g_cells[x].car
#define VARIABLE_GLOBAL_P(x) g_cells[x].cdr
#define CLOSURE(x) g_cells[x].cdr
#define CONTINUATION(x) g_cells[x].cdr
#define FUNCTION(x) g_functions[g_cells[x].cdr]
#define FUNCTION0(x) g_functions[g_cells[x].cdr].function
#define MACRO(x) g_cells[x].cdr
#define VALUE(x) g_cells[x].cdr
#define VECTOR(x) g_cells[x].cdr
@ -282,12 +287,16 @@ int g_function = 0;
#define LENGTH(x) g_cells[x].length
#define NAME(x) g_cells[x].name
#define STRING(x) g_cells[x].string
#define VARIABLE(x) g_cells[x].variable
#define VARIABLE_GLOBAL_P(x) g_cells[x].cdr
#define CLOSURE(x) g_cells[x].closure
#define MACRO(x) g_cells[x].macro
#define REF(x) g_cells[x].ref
#define VALUE(x) g_cells[x].value
#define VECTOR(x) g_cells[x].vector
#define FUNCTION(x) g_functions[g_cells[x].function]
#define FUNCTION0(x) g_functions[g_cells[x].function].function0
#define NLENGTH(x) g_news[x].length
@ -342,15 +351,15 @@ make_cell_ (SCM type, SCM car, SCM cdr)
TYPE (x) = VALUE (type);
if (VALUE (type) == TCHAR || VALUE (type) == TNUMBER) {
if (car) CAR (x) = CAR (car);
if (cdr) CDR(x) = CDR(cdr);
if (cdr) CDR (x) = CDR (cdr);
}
else if (VALUE (type) == TFUNCTION) {
if (car) CAR (x) = car;
if (cdr) CDR(x) = CDR(cdr);
if (cdr) CDR (x) = CDR (cdr);
}
else {
CAR (x) = car;
CDR(x) = cdr;
CDR (x) = cdr;
}
return x;
}
@ -689,7 +698,11 @@ set_cdr_x (SCM x, SCM e)
SCM
set_env_x (SCM x, SCM e, SCM a)
{
SCM p = assert_defined (x, assq (x, a));
SCM p;
if (TYPE (x) == TVARIABLE)
p = VARIABLE (x);
else
p = assert_defined (x, assq (x, a));
if (TYPE (p) != TPAIR) error (cell_symbol_not_a_pair, cons (p, x));
return set_cdr_x (p, e);
}
@ -709,12 +722,18 @@ make_closure_ (SCM args, SCM body, SCM a) ///((internal))
return make_cell_ (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
}
SCM
make_variable_ (SCM var, SCM global_p) ///((internal))
{
return make_cell_ (tmp_num_ (TVARIABLE), var, global_p);
}
SCM
lookup_macro_ (SCM x, SCM a) ///((internal))
{
if (TYPE (x) != TSYMBOL) return cell_f;
SCM m = assq_ref_env (x, a);
if (TYPE (m) == TMACRO) return MACRO (m);
SCM m = assq (x, a);
if (m != cell_f) return MACRO (CDR (m));
return cell_f;
}
@ -750,10 +769,104 @@ gc_pop_frame () ///((internal))
return frame;
}
char const* string_to_cstring (SCM s);
SCM
add_formals (SCM formals, SCM x)
{
while (TYPE (x) == TPAIR)
{
formals = cons (CAR (x), formals);
x = CDR (x);
}
if (TYPE (x) == TSYMBOL)
formals = cons (x, formals);
return formals;
}
int
formal_p (SCM x, SCM formals) /// ((internal))
{
if (TYPE (formals) == TSYMBOL)
{
if (x == formals) return x;
else return cell_f;
}
while (TYPE (formals) == TPAIR && CAR (formals) != x)
formals = CDR (formals);
if (TYPE (formals) == TSYMBOL)
return formals == x;
return TYPE (formals) == TPAIR;
}
SCM
expand_variable_ (SCM x, SCM formals, int top_p) ///((internal))
{
while (TYPE (x) == TPAIR)
{
if (TYPE (CAR (x)) == TPAIR)
{
if (CAAR (x) == cell_symbol_lambda)
{
SCM f = CAR (CDAR (x));
formals = add_formals (formals, f);
}
else if (CAAR (x) == cell_symbol_define
|| CAAR (x) == cell_symbol_define_macro)
{
SCM f = CAR (CDAR (x));
formals = add_formals (formals, f);
}
if (CAAR (x) != cell_symbol_quote)
expand_variable_ (CAR (x), formals, 0);
}
else
{
if (CAR (x) == cell_symbol_lambda)
{
SCM f = CADR (x);
formals = add_formals (formals, f);
x = CDR (x);
}
else if (CAR (x) == cell_symbol_define
|| CAR (x) == cell_symbol_define_macro)
{
SCM f = CADR (x);
if (top_p && TYPE (f) == TPAIR)
f = CDR (f);
formals = add_formals (formals, f);
x = CDR (x);
}
else if (CAR (x) == cell_symbol_quote)
return cell_unspecified;
else if (TYPE (CAR (x)) == TSYMBOL
&& CAR (x) != cell_begin
&& CAR (x) != cell_symbol_begin
&& CAR (x) != cell_symbol_current_module
&& CAR (x) != cell_symbol_primitive_load
&& CAR (x) != cell_symbol_if // HMM
&& !formal_p (CAR (x), formals))
{
SCM v = assq (CAR (x), r0);
if (v != cell_f)
CAR (x) = make_variable_ (v, cell_t);
}
}
x = CDR (x);
top_p = 0;
}
return cell_unspecified;
}
SCM
expand_variable (SCM x, SCM formals) ///((internal))
{
return expand_variable_ (x, formals, 1);
}
SCM
eval_apply ()
{
int expanding_p = 0;
eval_apply:
gc_check ();
switch (r3)
@ -764,12 +877,8 @@ eval_apply ()
case cell_vm_apply: goto apply;
case cell_vm_apply2: goto apply2;
case cell_vm_eval: goto eval;
#if MES_FIXED_PRIMITIVES
case cell_vm_eval_car: goto eval_car;
case cell_vm_eval_cdr: goto eval_cdr;
case cell_vm_eval_cons: goto eval_cons;
case cell_vm_eval_null_p: goto eval_null_p;
#endif
case cell_vm_eval_pmatch_car: goto eval_pmatch_car;
case cell_vm_eval_pmatch_cdr: goto eval_pmatch_cdr;
case cell_vm_eval_define: goto eval_define;
case cell_vm_eval_set_x: goto eval_set_x;
case cell_vm_eval_macro_expand_eval: goto eval_macro_expand_eval;
@ -818,7 +927,8 @@ eval_apply ()
gc_check ();
switch (TYPE (CAR (r1)))
{
case TFUNCTION: {
case TFUNCTION:
{
check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
goto vm_return;
@ -826,12 +936,13 @@ eval_apply ()
case TCLOSURE:
{
SCM cl = CLOSURE (CAR (r1));
SCM formals = CADR (cl);
SCM body = CDDR (cl);
SCM formals = CADR (cl);
SCM args = CDR (r1);
SCM aa = CDAR (cl);
aa = CDR (aa);
check_formals (CAR (r1), formals, CDR (r1));
SCM p = pairlis (formals, CDR (r1), aa);
SCM p = pairlis (formals, args, aa);
call_lambda (body, p, aa, r0);
goto begin;
}
@ -886,9 +997,10 @@ eval_apply ()
case cell_symbol_lambda:
{
SCM formals = CADR (CAR (r1));
SCM args = CDR (r1);
SCM body = CDDR (CAR (r1));
SCM p = pairlis (formals, CDR (r1), r0);
check_formals (r1, formals, CDR (r1));
check_formals (r1, formals, args);
call_lambda (body, p, p, r0);
goto begin;
}
@ -910,59 +1022,50 @@ eval_apply ()
{
switch (CAR (r1))
{
#if MES_FIXED_PRIMITIVES
case cell_symbol_car:
case cell_symbol_pmatch_car:
{
push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
eval_car:
x = r1; gc_pop_frame (); r1 = CAR (x); goto eval_apply;
}
case cell_symbol_cdr:
{
push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval;
eval_cdr:
x = r1; gc_pop_frame (); r1 = CDR (x); goto eval_apply;
}
case cell_symbol_cons: {
push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis;
eval_cons:
push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
goto eval;
eval_pmatch_car:
x = r1;
gc_pop_frame ();
r1 = cons (CAR (x), CADR (x));
r1 = CAR (x);
goto eval_apply;
}
case cell_symbol_null_p:
case cell_symbol_pmatch_cdr:
{
push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p);
push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr);
goto eval;
eval_null_p:
x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
eval_pmatch_cdr:
x = r1;
gc_pop_frame ();
r1 = CDR (x);
goto eval_apply;
}
#else
eval_car:;
eval_cdr:;
eval_cons:;
eval_null_p:;
#endif // MES_FIXED_PRIMITIVES
case cell_symbol_quote:
{
x = r1; gc_pop_frame (); r1 = CADR (x); goto eval_apply;
x = r1;
gc_pop_frame ();
r1 = CADR (x);
goto eval_apply;
}
case cell_symbol_begin: goto begin;
case cell_symbol_lambda:
{
r1 = make_closure_ (CADR (r1), CDDR (r1), assq (cell_closure, r0));
r1 = make_closure_ (CADR (r1), CDDR (r1), r0);
goto vm_return;
}
case cell_symbol_if: {r1=CDR (r1); goto vm_if;}
case cell_symbol_if:
{
r1=CDR (r1);
goto vm_if;
}
case cell_symbol_set_x:
{
push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
goto eval;
eval_set_x:
x = r2;
r1 = set_env_x (CADR (x), r1, r0);
r1 = set_env_x (CADR (r2), r1, r0);
goto vm_return;
}
case cell_vm_macro_expand:
@ -971,10 +1074,8 @@ eval_apply ()
goto eval;
eval_macro_expand_eval:
push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand);
expanding_p++;
goto macro_expand;
eval_macro_expand_expand:
expanding_p--;
goto vm_return;
}
default:
@ -983,6 +1084,34 @@ eval_apply ()
&& (CAR (r1) == cell_symbol_define
|| CAR (r1) == cell_symbol_define_macro))
{
int global_p = CAAR (r0) != cell_closure;
int macro_p = CAR (r1) == cell_symbol_define_macro;
if (global_p)
{
SCM name = CADR (r1);
if (TYPE (CADR (r1)) == TPAIR)
name = CAR (name);
if (macro_p)
{
SCM entry = assq (name, g_macros);
if (entry == cell_f)
{
entry = cons (name, cell_f);
g_macros = cons (entry, g_macros);
}
}
else
{
SCM entry = assq (name, r0);
if (entry == cell_f)
{
entry = cons (name, cell_f);
SCM aa = cons (entry, cell_nil);
set_cdr_x (aa, cdr (r0));
set_cdr_x (r0, aa);
}
}
}
r2 = r1;
if (TYPE (CADR (r1)) != TPAIR)
{
@ -992,30 +1121,46 @@ eval_apply ()
else
{
SCM p = pairlis (CADR (r1), CADR (r1), r0);
SCM args = CDR (CADR (r1));
SCM formals = CDR (CADR (r1));
SCM body = CDDR (r1);
r1 = cons (cell_symbol_lambda, cons (args, body));
if (macro_p || global_p) expand_variable (body, formals);
r1 = cons (cell_symbol_lambda, cons (formals, body));
push_cc (r1, r2, p, cell_vm_eval_define);
goto eval;
}
eval_define:;
SCM name = CADR (r2);
if (TYPE (CADR (r2)) == TPAIR) name = CAR (name);
if (CAR (r2) == cell_symbol_define_macro)
if (TYPE (CADR (r2)) == TPAIR)
name = CAR (name);
if (macro_p)
{
SCM entry = assq (name, g_macros);
r1 = MAKE_MACRO (name, r1);
set_cdr_x (entry, r1);
}
else if (global_p)
{
SCM entry = assq (name, r0);
set_cdr_x (entry, r1);
}
else
{
SCM entry = cons (name, r1);
SCM aa = cons (entry, cell_nil);
set_cdr_x (aa, cdr (r0));
set_cdr_x (r0, aa);
SCM cl = assq (cell_closure, r0);
set_cdr_x (cl, aa);
//r1 = entry;
}
r1 = cell_unspecified;
goto vm_return;
}
push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func); goto eval;
push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func);
goto eval;
eval_check_func:
push_cc (CDR (r2), r2, r0, cell_vm_eval2); goto evlis;
push_cc (CDR (r2), r2, r0, cell_vm_eval2);
goto evlis;
eval2:
r1 = cons (CAR (r2), r1);
goto apply;
@ -1024,9 +1169,20 @@ eval_apply ()
}
case TSYMBOL:
{
if (r1 == cell_symbol_current_module) goto vm_return;
if (r1 == cell_symbol_begin) // FIXME
{
r1 = cell_begin;
goto vm_return;
}
r1 = assert_defined (r1, assq_ref_env (r1, r0));
goto vm_return;
}
case TVARIABLE:
{
r1 = CDR (VARIABLE (r1));
goto vm_return;
}
default: goto vm_return;
}
@ -1038,13 +1194,24 @@ eval_apply ()
if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote)
goto vm_return;
if (CAR (r1) == cell_symbol_lambda)
{
push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_lambda);
goto macro_expand;
macro_expand_lambda:
CDDR (r2) = r1;
r1 = r2;
goto vm_return;
}
if (TYPE (r1) == TPAIR
&& (macro = lookup_macro_ (CAR (r1), r0)) != cell_f)
&& (macro = lookup_macro_ (CAR (r1), g_macros)) != cell_f)
{
r1 = cons (macro, CDR (r1));
push_cc (r1, cell_nil, r0, cell_vm_macro_expand);
goto apply;
}
if (CAR (r1) == cell_symbol_define
|| CAR (r1) == cell_symbol_define_macro)
{
@ -1063,16 +1230,6 @@ eval_apply ()
goto vm_return;
}
if (CAR (r1) == cell_symbol_lambda)
{
push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_lambda);
goto macro_expand;
macro_expand_lambda:
CDDR (r2) = r1;
r1 = r2;
goto vm_return;
}
if (CAR (r1) == cell_symbol_set_x)
{
push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_set_x);
@ -1086,6 +1243,7 @@ eval_apply ()
if (TYPE (r1) == TPAIR
&& TYPE (CAR (r1)) == TSYMBOL
&& CAR (r1) != cell_symbol_begin
&& ((macro = assq (cell_symbol_portable_macro_expand, g_macros)) != cell_f)
&& ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
&& ((macro = assq (CAR (r1), expanders)) != cell_f))
{
@ -1192,10 +1350,8 @@ eval_apply ()
}
push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_macro);
expanding_p++;
goto macro_expand;
begin_expand_macro:
expanding_p--;
if (r1 != CAR (r2))
{
CAR (r2) = r1;
@ -1203,7 +1359,8 @@ eval_apply ()
continue;
}
r1 = r2;
expand_variable (CAR (r1), cell_nil);
//eputs ("expanded r1="); write_error_ (CAR (r1)); eputs ("\n");
push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_eval);
goto eval;
begin_expand_eval:
@ -1372,7 +1529,10 @@ mes_symbols () ///((internal))
a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
a = acons (cell_symbol_dot, cell_dot, a);
a = acons (cell_symbol_begin, cell_begin, a);
a = acons (cell_symbol_quasisyntax, cell_symbol_quasisyntax, a);
a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
@ -1403,7 +1563,7 @@ mes_builtins (SCM a) ///((internal))
#if !__GNUC__ || !_POSIX_SOURCE
#include "mes.mes.i"
// Do not sort: Order of these includes define builtins
// Do not sort: Order of these includes define builtins
#include "posix.mes.i"
#include "math.mes.i"
#include "lib.mes.i"
@ -1421,7 +1581,7 @@ mes_builtins (SCM a) ///((internal))
#else
#include "mes.i"
// Do not sort: Order of these includes define builtins
// Do not sort: Order of these includes define builtins
#include "posix.i"
#include "math.i"
#include "lib.i"

View file

@ -334,7 +334,7 @@ dump ()
eputs ("\n");
}
for (int i=0; i<g_free * sizeof(struct scm); i++)
for (int i=0; i<g_free * sizeof (struct scm); i++)
putchar (*p++);
return 0;
}

View file

@ -28,7 +28,11 @@ exit $?
(cond-expand
(guile
(use-modules (system base pmatch)))
(use-modules (system base pmatch))
;;(include-from-path "mes/pmatch.scm")
;;(include-from-path "mes-0.scm")
;;(include-from-path "mes/test.mes")
)
(mes
(mes-use-module (mes test))
(mes-use-module (mes pmatch))))