andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
make.scm
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")))

4
module/language/c99/compiler.mes
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)))

5
module/mes/boot-0.scm
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)

6
module/mes/display.mes
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)

4
module/mes/guile.scm
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)

34
module/mes/module.mes
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")
)

14
module/mes/pmatch.scm
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))))

1
module/mes/psyntax-1.mes
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)

13
module/mes/type-0.mes
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>))

2
scaffold/boot/51-module.scm
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))

13
src/gc.c
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)
{

21
src/lib.c
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);

386
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;
}
@ -654,8 +663,8 @@ assq (SCM x, SCM a)
SCM v = STRING (x);
while (a != cell_nil && v != STRING (CAAR (a))) a = CDR (a); break;
}
// case TSYMBOL:
// case TSPECIAL:
// case TSYMBOL:
// case TSPECIAL:
default:
while (a != cell_nil && x != CAAR (a)) a = CDR (a); break;
}
@ -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,31 +927,33 @@ eval_apply ()
gc_check ();
switch (TYPE (CAR (r1)))
{
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;
}
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;
}
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;
}
case TCONTINUATION:
{
x = r1;
g_stack = CONTINUATION (CAR (r1));
gc_pop_frame ();
r1 = CADR (x);
goto eval_apply;
}
case TCONTINUATION:
{
x = r1;
g_stack = CONTINUATION (CAR (r1));
gc_pop_frame ();
r1 = CADR (x);
goto eval_apply;
}
case TSPECIAL:
{
switch (CAR (r1))
@ -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:
x = r1;
gc_pop_frame ();
r1 = cons (CAR (x), CADR (x));
goto eval_apply;
}
case cell_symbol_null_p:
{
push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p);
push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
goto eval;
eval_null_p:
x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
eval_pmatch_car:
x = r1;
gc_pop_frame ();
r1 = CAR (x);
goto eval_apply;
}
case cell_symbol_pmatch_cdr:
{
push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr);
goto eval;
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,18 +1074,44 @@ 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:
{
if (TYPE (r1) == TPAIR
&& (CAR (r1) == cell_symbol_define
|| CAR (r1) == cell_symbol_define_macro))
|| 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,41 +1121,68 @@ 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)
r1 = MAKE_MACRO (name, r1);
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;
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 = 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;
}
}
}
}
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"

2
src/reader.c
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;
}

6
tests/pmatch.test
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))))