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

mini-mes: Fully remove reader from core. 

* scaffold/mini-mes.c (lookup_): Remove.
* mes.c: Likewise.
* reader.c (lookup_): Enable.
* mlib.c (putc): New function.
* module/mes/libc.mes (putc): New function.
This commit is contained in:
Jan Nieuwenhuizen 2017-03-25 15:58:44 +01:00
parent 040b9aedfc
commit 30743ce141
21 changed files with 669 additions and 900 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
GNUmakefile
View File

@ -101,6 +101,7 @@ dump: module/mes/read-0.mo
mes-32: mes.c lib.c mes-32: mes.c lib.c
rm -f mes mes.o rm -f mes mes.o
guix environment --system=i686-linux --ad-hoc gcc-toolchain -- bash -c 'make mes CC=i686-unknown-linux-gnu-gcc LIBRARY_PATH=$${PATH%%/bin:*}/lib' guix environment --system=i686-linux --ad-hoc gcc-toolchain -- bash -c 'make mes CC=i686-unknown-linux-gnu-gcc LIBRARY_PATH=$${PATH%%/bin:*}/lib'
rm -f mes.o
mv mes mes-32 mv mes mes-32
module/mes/read-0-32.mo: module/mes/read-0.mes mes-32 module/mes/read-0-32.mo: module/mes/read-0.mes mes-32
@ -135,6 +136,7 @@ mini-mes: scaffold/mini-mes.c
rm -f $@ rm -f $@
# gcc -nostdlib --std=gnu99 -m32 -g -o $@ '-DPREFIX=' '-DVERSION='"$(VERSION)"' $< # gcc -nostdlib --std=gnu99 -m32 -g -o $@ '-DPREFIX=' '-DVERSION='"$(VERSION)"' $<
gcc -nostdlib -I. --std=gnu99 -m32 -g -I. -o $@ $(CPPFLAGS) $< gcc -nostdlib -I. --std=gnu99 -m32 -g -I. -o $@ $(CPPFLAGS) $<
rm -f mes.o
chmod +x $@ chmod +x $@
guile-mini-mes: mini-mes.h mini-mes.i mini-mes.environment.i mini-mes.symbols.i guile-mini-mes: mini-mes.h mini-mes.i mini-mes.environment.i mini-mes.symbols.i

9
build-aux/mes-snarf.scm
View File

@ -57,10 +57,11 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
(regexp-replace "_" "-") (regexp-replace "_" "-")
(regexp-replace "_" "-") (regexp-replace "_" "-")
(regexp-replace "_" "-") (regexp-replace "_" "-")
(regexp-replace "^builtin_" "")
(regexp-replace "_to_" "->") (regexp-replace "_to_" "->")
(regexp-replace "_x$" "!") (regexp-replace "_x$" "!")
(regexp-replace "_p$" "?")) (regexp-replace "_p$" "?")
(regexp-replace "___" "***")
(regexp-replace "___" "***"))
(.name f)))) (.name f))))
(if (not (string-suffix? "-" name)) name (if (not (string-suffix? "-" name)) name
(string-append "core:" (string-drop-right name 1)))))) (string-append "core:" (string-drop-right name 1))))))
@ -120,8 +121,8 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
(format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (.name f) (.name f)) (format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (.name f) (.name f))
(format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (.name f) (.name f))) (format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (.name f) (.name f)))
(if GCC? (if GCC?
(format #f "a = acons (make_symbol (scm_~a.string), ~a, a);\n\n" (.name f) (function-cell-name f)) (format #f "a = acons (lookup_symbol_ (scm_~a.string), ~a, a);\n\n" (.name f) (function-cell-name f))
(format #f "a = acons (make_symbol (scm_~a.car), ~a, a);\n\n" (.name f) (function-cell-name f))))) (format #f "a = acons (lookup_symbol_ (scm_~a.car), ~a, a);\n\n" (.name f) (function-cell-name f)))))
(define (snarf-symbols string) (define (snarf-symbols string)
(let* ((matches (list-matches "\nstruct scm scm_([a-z_0-9]+) = [{](TSPECIAL|TSYMBOL)," string))) (let* ((matches (list-matches "\nstruct scm scm_([a-z_0-9]+) = [{](TSPECIAL|TSYMBOL)," string)))

152
lib.c
View File

@ -1,6 +1,6 @@
/* -*-comment-start: "//";comment-end:""-*- /* -*-comment-start: "//";comment-end:""-*-
* Mes --- Maxwell Equations of Software * Mes --- Maxwell Equations of Software
* Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> * Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
* *
* This file is part of Mes. * This file is part of Mes.
* *
@ -32,6 +32,137 @@
// return MAKE_NUMBER (n); // return MAKE_NUMBER (n);
// } // }
SCM fdisplay_ (SCM,FILE*);
int g_depth;
SCM
display_helper (SCM x, int cont, char* sep, FILE *fd)
{
fputs (sep, fd);
if (g_depth == 0) return cell_unspecified;
g_depth = g_depth - 1;
switch (TYPE (x))
{
case TCHAR:
{
fputs ("#\\", fd);
putc (VALUE (x), fd);
break;
}
case TFUNCTION:
{
fputs ("#<procedure ", fd);
char *p = "?";
if (FUNCTION (x).name != 0)
p = FUNCTION (x).name;
fputs (p, fd);
fputs ("[", fd);
fputs (itoa (CDR (x)), fd);
fputs (",", fd);
fputs (itoa (x), fd);
fputs ("]>", fd);
break;
}
case TMACRO:
{
fputs ("#<macro ", fd);
display_helper (cdr (x), cont, "", fd);
fputs (">", fd);
break;
}
case TNUMBER:
{
fputs (itoa (VALUE (x)), fd);
break;
}
case TPAIR:
{
if (!cont) fputs ("(", fd);
if (x && x != cell_nil) fdisplay_ (CAR (x), fd);
if (CDR (x) && TYPE (CDR (x)) == TPAIR)
display_helper (CDR (x), 1, " ", fd);
else if (CDR (x) && CDR (x) != cell_nil)
{
if (TYPE (CDR (x)) != TPAIR)
fputs (" . ", fd);
fdisplay_ (CDR (x), fd);
}
if (!cont) fputs (")", fd);
break;
}
case TSPECIAL:
#if __NYACC__
// FIXME
//{}
{
SCM t = CAR (x);
while (t && t != cell_nil)
{
putc (VALUE (CAR (t)), fd);
t = CDR (t);
}
break;
}
#endif
case TSTRING:
#if __NYACC__
// FIXME
{
SCM t = CAR (x);
while (t && t != cell_nil)
{
putc (VALUE (CAR (t)), fd);
t = CDR (t);
}
break;
}
#endif
case TSYMBOL:
{
SCM t = CAR (x);
while (t && t != cell_nil)
{
putc (VALUE (CAR (t)), fd);
t = CDR (t);
}
break;
}
default:
{
fputs ("<", fd);
fputs (itoa (TYPE (x)), fd);
fputs (":", fd);
fputs (itoa (x), fd);
fputs (">", fd);
break;
}
}
return 0;
}
SCM
display_ (SCM x)
{
g_depth = 5;
return display_helper (x, 0, "", stdout);
}
SCM
display_error_ (SCM x)
{
g_depth = 5;
return display_helper (x, 0, "", stderr);
}
SCM
fdisplay_ (SCM x, FILE *fd) ///((internal))
{
g_depth = 5;
return display_helper (x, 0, "", fd);
}
SCM SCM
exit_ (SCM x) ///((name . "exit")) exit_ (SCM x) ///((name . "exit"))
{ {
@ -111,7 +242,7 @@ check_apply (SCM f, SCM e) ///((internal))
char buf[1024]; char buf[1024];
sprintf (buf, "cannot apply: %s:", type); sprintf (buf, "cannot apply: %s:", type);
fprintf (stderr, " ["); fprintf (stderr, " [");
stderr_ (e); display_error_ (e);
fprintf (stderr, "]\n"); fprintf (stderr, "]\n");
SCM e = MAKE_STRING (cstring_to_list (buf)); SCM e = MAKE_STRING (cstring_to_list (buf));
return error (cell_symbol_wrong_type_arg, cons (e, f)); return error (cell_symbol_wrong_type_arg, cons (e, f));
@ -147,7 +278,7 @@ int
dump () dump ()
{ {
fputs ("program r2=", stderr); fputs ("program r2=", stderr);
stderr_ (r2); display_error_ (r2);
fputs ("\n", stderr); fputs ("\n", stderr);
r1 = g_symbols; r1 = g_symbols;
@ -236,21 +367,6 @@ bload_env (SCM a) ///((internal))
return r2; return r2;
} }
SCM
values (SCM x) ///((arity . n))
{
SCM v = cons (0, x);
TYPE (v) = TVALUES;
return v;
}
SCM
arity_ (SCM x)
{
assert (TYPE (x) == TFUNCTION);
return MAKE_NUMBER (FUNCTION (x).arity);
}
SCM SCM
xassq (SCM x, SCM a) ///for speed in core only xassq (SCM x, SCM a) ///for speed in core only
{ {

2
math.c
View File

@ -1,6 +1,6 @@
/* -*-comment-start: "//";comment-end:""-*- /* -*-comment-start: "//";comment-end:""-*-
* Mes --- Maxwell Equations of Software * Mes --- Maxwell Equations of Software
* Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> * Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
* *
* This file is part of Mes. * This file is part of Mes.
* *

306
mes.c
View File

@ -213,19 +213,19 @@ SCM r3 = 0; // continuation
#define NTYPE(x) g_news[x].type #define NTYPE(x) g_news[x].type
#define CAAR(x) CAR (CAR (x)) #define CAAR(x) CAR (CAR (x))
#define CADR(x) CAR (CDR (x))
#define CDAR(x) CDR (CAR (x)) #define CDAR(x) CDR (CAR (x))
#define CAAR(x) CAR (CAR (x)) #define CDDR(x) CDR (CDR (x))
#define CADAR(x) CAR (CDR (CAR (x))) #define CADAR(x) CAR (CDR (CAR (x)))
#define CADDR(x) CAR (CDR (CDR (x))) #define CADDR(x) CAR (CDR (CDR (x)))
#define CDDDR(x) CDR (CDR (CDR (x))) #define CDDDR(x) CDR (CDR (CDR (x)))
#define CDADAR(x) CAR (CDR (CAR (CDR (x)))) #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
#define CADR(x) CAR (CDR (x))
#define MAKE_CHAR(n) make_cell (tmp_num_ (TCHAR), 0, tmp_num2_ (n)) #define MAKE_CHAR(n) make_cell_ (tmp_num_ (TCHAR), 0, tmp_num2_ (n))
#define MAKE_CONTINUATION(n) make_cell (tmp_num_ (TCONTINUATION), n, g_stack) #define MAKE_CONTINUATION(n) make_cell_ (tmp_num_ (TCONTINUATION), n, g_stack)
#define MAKE_NUMBER(n) make_cell (tmp_num_ (TNUMBER), 0, tmp_num2_ (n)) #define MAKE_NUMBER(n) make_cell_ (tmp_num_ (TNUMBER), 0, tmp_num2_ (n))
#define MAKE_REF(n) make_cell (tmp_num_ (TREF), n, 0) #define MAKE_REF(n) make_cell_ (tmp_num_ (TREF), n, 0)
#define MAKE_STRING(x) make_cell (tmp_num_ (TSTRING), x, 0) #define MAKE_STRING(x) make_cell_ (tmp_num_ (TSTRING), x, 0)
SCM vm_call (function0_t f, SCM p1, SCM a); SCM vm_call (function0_t f, SCM p1, SCM a);
char const* itoa(int); char const* itoa(int);
@ -256,7 +256,7 @@ alloc (int n)
} }
SCM SCM
make_cell (SCM type, SCM car, SCM cdr) make_cell_ (SCM type, SCM car, SCM cdr)
{ {
SCM x = alloc (1); SCM x = alloc (1);
assert (TYPE (type) == TNUMBER); assert (TYPE (type) == TNUMBER);
@ -274,11 +274,79 @@ make_cell (SCM type, SCM car, SCM cdr)
return x; return x;
} }
SCM
make_symbol_ (SCM s)
{
g_cells[tmp_num].value = TSYMBOL;
SCM x = make_cell_ (tmp_num, s, 0);
g_symbols = cons (x, g_symbols);
return x;
}
SCM
list_of_char_equal_p (SCM a, SCM b) ///((internal))
{
while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) {
assert (TYPE (car (a)) == TCHAR);
assert (TYPE (car (b)) == TCHAR);
a = cdr (a);
b = cdr (b);
}
return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
}
SCM
lookup_symbol_ (SCM s)
{
SCM x = g_symbols;
while (x) {
if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break;
x = cdr (x);
}
if (x) x = car (x);
if (!x) x = make_symbol_ (s);
return x;
}
SCM
type_ (SCM x)
{
return MAKE_NUMBER (TYPE (x));
}
SCM
car_ (SCM x)
{
return (TYPE (x) != TCONTINUATION
&& (TYPE (CAR (x)) == TPAIR // FIXME: this is weird
|| TYPE (CAR (x)) == TREF
|| TYPE (CAR (x)) == TSPECIAL
|| TYPE (CAR (x)) == TSYMBOL
|| TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
}
SCM
cdr_ (SCM x)
{
return (TYPE (CDR (x)) == TPAIR
|| TYPE (CDR (x)) == TREF
|| TYPE (CAR (x)) == TSPECIAL
|| TYPE (CDR (x)) == TSYMBOL
|| TYPE (CDR (x)) == TSTRING) ? CDR (x) : MAKE_NUMBER (CDR (x));
}
SCM
arity_ (SCM x)
{
assert (TYPE (x) == TFUNCTION);
return MAKE_NUMBER (FUNCTION (x).arity);
}
SCM SCM
cons (SCM x, SCM y) cons (SCM x, SCM y)
{ {
g_cells[tmp_num].value = TPAIR; g_cells[tmp_num].value = TPAIR;
return make_cell (tmp_num, x, y); return make_cell_ (tmp_num, x, y);
} }
SCM SCM
@ -321,30 +389,17 @@ eq_p (SCM x, SCM y)
} }
SCM SCM
type_ (SCM x) values (SCM x) ///((arity . n))
{ {
return MAKE_NUMBER (TYPE (x)); SCM v = cons (0, x);
TYPE (v) = TVALUES;
return v;
} }
SCM SCM
car_ (SCM x) acons (SCM key, SCM value, SCM alist)
{ {
return (TYPE (x) != TCONTINUATION return cons (cons (key, value), alist);
&& (TYPE (CAR (x)) == TPAIR // FIXME: this is weird
|| TYPE (CAR (x)) == TREF
|| TYPE (CAR (x)) == TSPECIAL
|| TYPE (CAR (x)) == TSYMBOL
|| TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
}
SCM
cdr_ (SCM x)
{
return (TYPE (CDR (x)) == TPAIR
|| TYPE (CDR (x)) == TREF
|| TYPE (CAR (x)) == TSPECIAL
|| TYPE (CDR (x)) == TSYMBOL
|| TYPE (CDR (x)) == TSTRING) ? CDR (x) : MAKE_NUMBER (CDR (x));
} }
// MIMI_MES lib.c? // MIMI_MES lib.c?
@ -367,6 +422,9 @@ error (SCM key, SCM x)
SCM throw; SCM throw;
if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined) if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
return apply (throw, cons (key, cons (x, cell_nil)), r0); return apply (throw, cons (key, cons (x, cell_nil)), r0);
display_error_ (key);
fputs (": ", stderr);
display_error_ (x);
assert (!"error"); assert (!"error");
} }
@ -408,18 +466,12 @@ call (SCM fn, SCM x)
if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1) if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
&& x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES) && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
x = cons (CAR (x), cons (CDADAR (x), CDR (x))); x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
#if 0
eputs ("call: ");
if (FUNCTION (fn).name) eputs (FUNCTION (fn).name);
else eputs (itoa (CDR (fn)));
eputs ("\n");
#endif
switch (FUNCTION (fn).arity) switch (FUNCTION (fn).arity)
{ {
case 0: return FUNCTION (fn).function0 (); case 0: return FUNCTION (fn).function0 ();
case 1: return FUNCTION (fn).function1 (car (x)); case 1: return FUNCTION (fn).function1 (car (x));
case 2: return FUNCTION (fn).function2 (car (x), cadr (x)); case 2: return FUNCTION (fn).function2 (car (x), CADR (x));
case 3: return FUNCTION (fn).function3 (car (x), cadr (x), car (cddr (x))); case 3: return FUNCTION (fn).function3 (car (x), CADR (x), car (CDDR (x)));
case -1: return FUNCTION (fn).functionn (x); case -1: return FUNCTION (fn).functionn (x);
} }
@ -430,7 +482,7 @@ SCM
assq (SCM x, SCM a) assq (SCM x, SCM a)
{ {
while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a); while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a);
return a != cell_nil ? car (a) : cell_f; return a != cell_nil ? CAR (a) : cell_f;
} }
SCM SCM
@ -438,7 +490,7 @@ assq_ref_env (SCM x, SCM a)
{ {
x = assq (x, a); x = assq (x, a);
if (x == cell_f) return cell_undefined; if (x == cell_f) return cell_undefined;
return cdr (x); return CDR (x);
} }
SCM SCM
@ -475,28 +527,16 @@ call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
} }
SCM SCM
make_closure (SCM args, SCM body, SCM a) make_closure_ (SCM args, SCM body, SCM a) ///((internal))xs
{ {
return make_cell (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body))); return make_cell_ (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
} }
SCM SCM
lookup_macro (SCM x, SCM a) lookup_macro_ (SCM x, SCM a) ///((internal))
{ {
if (TYPE (x) != TSYMBOL) return cell_f; if (TYPE (x) != TSYMBOL) return cell_f;
SCM m = assq_ref_env (x, a); SCM m = assq_ref_env (x, a);
#if 0
if (TYPE (m) == TMACRO)
{
fputs ("XXmacro: ", stdout);
fputs ("[", stdout);
fputs (itoa (m), stdout);
fputs ("]: ", stdout);
display_ (m);
fputs ("\n", stdout);
}
#endif
if (TYPE (m) == TMACRO) return MACRO (m); if (TYPE (m) == TMACRO) return MACRO (m);
return cell_f; return cell_f;
} }
@ -514,11 +554,6 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
return cell_unspecified; return cell_unspecified;
} }
SCM caar (SCM x) {return car (car (x));}
SCM cadr (SCM x) {return car (cdr (x));}
SCM cdar (SCM x) {return cdr (car (x));}
SCM cddr (SCM x) {return cdr (cdr (x));}
SCM SCM
eval_apply () eval_apply ()
{ {
@ -582,9 +617,9 @@ eval_apply ()
case TCLOSURE: case TCLOSURE:
{ {
SCM cl = CLOSURE (car (r1)); SCM cl = CLOSURE (car (r1));
SCM formals = cadr (cl); SCM formals = CADR (cl);
SCM body = cddr (cl); SCM body = CDDR (cl);
SCM aa = cdar (cl); SCM aa = CDAR (cl);
aa = cdr (aa); aa = cdr (aa);
check_formals (car (r1), formals, cdr (r1)); check_formals (car (r1), formals, cdr (r1));
SCM p = pairlis (formals, cdr (r1), aa); SCM p = pairlis (formals, cdr (r1), aa);
@ -596,7 +631,7 @@ eval_apply ()
x = r1; x = r1;
g_stack = CONTINUATION (CAR (r1)); g_stack = CONTINUATION (CAR (r1));
gc_pop_frame (); gc_pop_frame ();
r1 = cadr (x); r1 = CADR (x);
goto eval_apply; goto eval_apply;
} }
case TSPECIAL: case TSPECIAL:
@ -637,12 +672,12 @@ eval_apply ()
} }
case TPAIR: case TPAIR:
{ {
switch (caar (r1)) switch (CAAR (r1))
{ {
case cell_symbol_lambda: case cell_symbol_lambda:
{ {
SCM formals = cadr (car (r1)); SCM formals = CADR (car (r1));
SCM body = cddr (car (r1)); SCM body = CDDR (car (r1));
SCM p = pairlis (formals, cdr (r1), r0); SCM p = pairlis (formals, cdr (r1), r0);
check_formals (r1, formals, cdr (r1)); check_formals (r1, formals, cdr (r1));
call_lambda (body, p, p, r0); call_lambda (body, p, p, r0);
@ -696,27 +731,27 @@ eval_apply ()
#endif // FIXED_PRIMITIVES #endif // FIXED_PRIMITIVES
case cell_symbol_quote: 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_begin: goto begin;
case cell_symbol_lambda: case cell_symbol_lambda:
{ {
r1 = make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0)); r1 = make_closure_ (CADR (r1), CDDR (r1), assq (cell_closure, r0));
goto vm_return; 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: case cell_symbol_set_x:
{ {
push_cc (car (cddr (r1)), r1, r0, cell_vm_eval_set_x); push_cc (car (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
goto eval; goto eval;
eval_set_x: eval_set_x:
x = r2; x = r2;
r1 = set_env_x (cadr (x), r1, r0); r1 = set_env_x (CADR (x), r1, r0);
goto vm_return; goto vm_return;
} }
case cell_vm_macro_expand: case cell_vm_macro_expand:
{ {
push_cc (cadr (r1), r1, r0, cell_vm_return); push_cc (CADR (r1), r1, r0, cell_vm_return);
goto macro_expand; goto macro_expand;
} }
default: { default: {
@ -752,17 +787,9 @@ eval_apply ()
SCM expanders; SCM expanders;
macro_expand: macro_expand:
if (TYPE (r1) == TPAIR if (TYPE (r1) == TPAIR
&& (macro = lookup_macro (car (r1), r0)) != cell_f) && (macro = lookup_macro_ (car (r1), r0)) != cell_f)
{ {
r1 = cons (macro, CDR (r1)); r1 = cons (macro, CDR (r1));
#if 0
fputs ("macro: ", stdout);
display_ (macro);
fputs ("\n", stdout);
fputs ("r1: ", stdout);
display_ (r1);
fputs ("\n", stdout);
#endif
goto apply; goto apply;
} }
else if (TYPE (r1) == TPAIR else if (TYPE (r1) == TPAIR
@ -784,9 +811,9 @@ eval_apply ()
while (r1 != cell_nil) { while (r1 != cell_nil) {
if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR) if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
{ {
if (caar (r1) == cell_symbol_begin) if (CAAR (r1) == cell_symbol_begin)
r1 = append2 (cdar (r1), cdr (r1)); r1 = append2 (CDAR (r1), cdr (r1));
else if (caar (r1) == cell_symbol_primitive_load) else if (CAAR (r1) == cell_symbol_primitive_load)
{ {
push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file); push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
goto apply; goto apply;
@ -797,11 +824,6 @@ eval_apply ()
if (CDR (r1) == cell_nil) if (CDR (r1) == cell_nil)
{ {
r1 = car (r1); r1 = car (r1);
#if 0
fputs ("begin: ", stdout);
display_ (r1);
fputs ("\n", stdout);
#endif
goto eval; goto eval;
} }
push_cc (CAR (r1), r1, r0, cell_vm_begin2); push_cc (CAR (r1), r1, r0, cell_vm_begin2);
@ -821,12 +843,12 @@ eval_apply ()
r1 = r2; r1 = r2;
if (x != cell_f) if (x != cell_f)
{ {
r1 = cadr (r1); r1 = CADR (r1);
goto eval; goto eval;
} }
if (cddr (r1) != cell_nil) if (CDDR (r1) != cell_nil)
{ {
r1 = car (cddr (r1)); r1 = car (CDDR (r1));
goto eval; goto eval;
} }
r1 = cell_unspecified; r1 = cell_unspecified;
@ -848,7 +870,7 @@ eval_apply ()
call_with_values2: call_with_values2:
if (TYPE (r1) == TVALUES) if (TYPE (r1) == TVALUES)
r1 = CDR (r1); r1 = CDR (r1);
r1 = cons (cadr (r2), r1); r1 = cons (CADR (r2), r1);
goto apply; goto apply;
vm_return: vm_return:
@ -863,9 +885,9 @@ gc_peek_frame () ///((internal))
{ {
SCM frame = car (g_stack); SCM frame = car (g_stack);
r1 = car (frame); r1 = car (frame);
r2 = cadr (frame); r2 = CADR (frame);
r3 = car (cddr (frame)); r3 = car (CDDR (frame));
r0 = cadr (cddr (frame)); r0 = CADR (CDDR (frame));
return frame; return frame;
} }
@ -892,76 +914,6 @@ apply (SCM f, SCM x, SCM a) ///((internal))
return eval_apply (); return eval_apply ();
} }
SCM
make_symbol_ (SCM s)
{
g_cells[tmp_num].value = TSYMBOL;
SCM x = make_cell (tmp_num, s, 0);
g_symbols = cons (x, g_symbols);
return x;
}
SCM
list_of_char_equal_p (SCM a, SCM b)
{
while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) {
assert (TYPE (car (a)) == TCHAR);
assert (TYPE (car (b)) == TCHAR);
a = cdr (a);
b = cdr (b);
}
return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
}
SCM
lookup_symbol_ (SCM s)
{
SCM x = g_symbols;
while (x) {
if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break;
x = cdr (x);
}
if (x) x = car (x);
return x;
}
SCM
make_symbol (SCM s)
{
SCM x = lookup_symbol_ (s);
return x ? x : make_symbol_ (s);
}
//MINI_MES reader.c
SCM
lookup_ (SCM s, SCM a)
{
if (isdigit (VALUE (car (s))) || (VALUE (car (s)) == '-' && cdr (s) != cell_nil)) {
SCM p = s;
int sign = 1;
if (VALUE (car (s)) == '-') {
sign = -1;
p = cdr (s);
}
int n = 0;
while (p != cell_nil && isdigit (VALUE (car (p)))) {
n *= 10;
n += VALUE (car (p)) - '0';
p = cdr (p);
}
if (p == cell_nil) return MAKE_NUMBER (n * sign);
}
SCM x = lookup_symbol_ (s);
return x ? x : make_symbol_ (s);
}
SCM
acons (SCM key, SCM value, SCM alist)
{
return cons (cons (key, value), alist);
}
void void
make_tmps (struct scm* cells) make_tmps (struct scm* cells)
{ {
@ -1041,8 +993,6 @@ mes_symbols () ///((internal))
return a; return a;
} }
#define gputs(x) fputs(x,stdout);
SCM SCM
mes_builtins (SCM a) ///((internal)) mes_builtins (SCM a) ///((internal))
{ {
@ -1051,9 +1001,9 @@ mes_builtins (SCM a) ///((internal))
#include "posix.i" #include "posix.i"
#include "math.i" #include "math.i"
#include "lib.i" #include "lib.i"
#include "reader.i"
#include "vector.i" #include "vector.i"
#include "gc.i" #include "gc.i"
#include "reader.i"
#include "gc.environment.i" #include "gc.environment.i"
#include "lib.environment.i" #include "lib.environment.i"
@ -1065,18 +1015,18 @@ mes_builtins (SCM a) ///((internal))
if (g_debug) if (g_debug)
{ {
gputs ("functions: "); fputs ("functions: ", stderr);
gputs (itoa (g_function)); fputs (itoa (g_function), stderr);
gputs ("\n"); fputs ("\n", stderr);
for (int i = 0; i < g_function; i++) for (int i = 0; i < g_function; i++)
{ {
gputs ("["); fputs ("[", stderr);
gputs (itoa (i)); fputs (itoa (i), stderr);
gputs ("]: "); fputs ("]: ", stderr);
gputs (g_functions[i].name); fputs (g_functions[i].name, stderr);
gputs ("\n"); fputs ("\n", stderr);
} }
gputs ("\n"); fputs ("\n", stderr);
} }
return a; return a;
@ -1128,11 +1078,11 @@ main (int argc, char *argv[])
for (int i=argc; i; i--) lst = cons (MAKE_STRING (cstring_to_list (argv[i-1])), lst); for (int i=argc; i; i--) lst = cons (MAKE_STRING (cstring_to_list (argv[i-1])), lst);
r0 = acons (cell_symbol_argv, lst, r0); r0 = acons (cell_symbol_argv, lst, r0);
if (g_debug) {eputs ("program: "); display_error_ (r2); eputs ("\n");}
push_cc (r2, cell_unspecified, r0, cell_unspecified); push_cc (r2, cell_unspecified, r0, cell_unspecified);
r3 = cell_vm_begin; r3 = cell_vm_begin;
r1 = eval_apply (); r1 = eval_apply ();
///stderr_ (r1); display_error_ (r1);
display_ (r1);
fputs ("", stdout); fputs ("", stdout);
gc (g_stack); gc (g_stack);
#if __GNUC__ #if __GNUC__

27
mlibc.c
View File

@ -29,6 +29,10 @@ void write (int fd, char const* s, int n);
#define O_RDONLY 0 #define O_RDONLY 0
#define INT_MIN -2147483648 #define INT_MIN -2147483648
#define INT_MAX 2147483647 #define INT_MAX 2147483647
#define EOF -1
#define STDIN 0
#define STDOUT 1
#define STDERR 2
void void
exit (int code) exit (int code)
@ -128,12 +132,17 @@ brk (void *p)
return r; return r;
} }
int
putc (int c, int fd)
{
write (fd, (char*)&c, 1);
return 0;
}
int int
putchar (int c) putchar (int c)
{ {
//write (STDOUT, s, strlen (s)); write (STDOUT, (char*)&c, 1);
//int i = write (STDOUT, s, strlen (s));
write (1, (char*)&c, 1);
return 0; return 0;
} }
@ -163,11 +172,6 @@ free (void *p)
//munmap ((void*)p, *n); //munmap ((void*)p, *n);
} }
#define EOF -1
#define STDIN 0
#define STDOUT 1
#define STDERR 2
size_t size_t
strlen (char const* s) strlen (char const* s)
{ {
@ -186,16 +190,14 @@ strcmp (char const* a, char const* b)
int int
eputs (char const* s) eputs (char const* s)
{ {
//int i = write (STDERR, s, strlen (s));
int i = strlen (s); int i = strlen (s);
write (2, s, i); write (STDERR, s, i);
return 0; return 0;
} }
int int
fputs (char const* s, int fd) fputs (char const* s, int fd)
{ {
//int i = write (fd, s, strlen (s));
int i = strlen (s); int i = strlen (s);
write (fd, s, i); write (fd, s, i);
return 0; return 0;
@ -204,9 +206,8 @@ fputs (char const* s, int fd)
int int
puts (char const* s) puts (char const* s)
{ {
//int i = write (STDOUT, s, strlen (s));
int i = strlen (s); int i = strlen (s);
write (1, s, i); write (STDOUT, s, i);
return 0; return 0;
} }

11
module/mes/base-0.mes
View File

@ -35,6 +35,11 @@
(define (primitive-eval e) (core:eval e (current-module))) (define (primitive-eval e) (core:eval e (current-module)))
(define eval core:eval) (define eval core:eval)
(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define-macro (defined? x) (define-macro (defined? x)
(list 'assq x '(cddr (current-module)))) (list 'assq x '(cddr (current-module))))
@ -107,9 +112,9 @@
(list 'begin (list 'begin
(list 'if (list getenv "MES_DEBUG") (list 'if (list getenv "MES_DEBUG")
(list 'begin (list 'begin
(list core:stderr "read ") (list core:display-error "read ")
(list core:stderr file) (list core:display-error file)
(list core:stderr "\n"))) (list core:display-error "\n")))
(list 'push! '*input-ports* (list current-input-port)) (list 'push! '*input-ports* (list current-input-port))
(list 'set-current-input-port (list open-input-file file)) (list 'set-current-input-port (list open-input-file file))
(list 'primitive-load) (list 'primitive-load)

21
module/mes/libc.mes
View File

@ -151,8 +151,6 @@ ungetc (int c, int fd)
int int
putchar (int c) putchar (int c)
{ {
//write (STDOUT, s, strlen (s));
//int i = write (STDOUT, s, strlen (s));
write (1, (char*)&c, 1); write (1, (char*)&c, 1);
return 0; return 0;
} }
@ -161,14 +159,26 @@ putchar (int c)
parse-c99))) parse-c99)))
ast)) ast))
(define putc
(let* ((ast (with-input-from-string
"
int
putc (int c, int fd)
{
write (fd, (char*)&c, 1);
return 0;
}
"
;;paredit:"
parse-c99)))
ast))
(define eputs (define eputs
(let* ((ast (with-input-from-string (let* ((ast (with-input-from-string
" "
int int
eputs (char const* s) eputs (char const* s)
{ {
//write (STDERR, s, strlen (s));
//write (2, s, strlen (s));
int i = strlen (s); int i = strlen (s);
write (2, s, i); write (2, s, i);
return 0; return 0;
@ -199,8 +209,6 @@ fputs (char const* s, int fd)
int int
puts (char const* s) puts (char const* s)
{ {
//write (STDOUT, s, strlen (s));
//int i = write (STDOUT, s, strlen (s));
int i = strlen (s); int i = strlen (s);
write (1, s, i); write (1, s, i);
return 0; return 0;
@ -323,6 +331,7 @@ realloc (int *p, int size)
assert_fail assert_fail
ungetc ungetc
putchar putchar
putc
eputs eputs
fputs fputs
puts puts

BIN
module/mes/read-0-32.mo Normal file
View File

Binary file not shown.

35
module/mes/read-0.mes
View File

@ -60,14 +60,14 @@
(set! sexp:define (set! sexp:define
(lambda (e a) (lambda (e a)
(if (atom? (cadr e)) (cons (cadr e) (core:eval (car (cddr e)) a)) (if (atom? (car (cdr e))) (cons (car (cdr e)) (core:eval (car (cdr (cdr e))) a))
(cons (car (cadr e)) (core:eval (cons (quote lambda) (cons (cdr (cadr e)) (cddr e))) a))))) (cons (car (car (cdr e))) (core:eval (cons (quote lambda) (cons (cdr (car (cdr e))) (cdr (cdr e)))) a)))))
(set! env:macro (set! env:macro
(lambda (name+entry) (lambda (name+entry)
(cons (cons
(cons (car name+entry) (cons (car name+entry)
(make-cell <cell:macro> (core:car (car name+entry)) (cdr name+entry))) (core:make-cell <cell:macro> (core:car (car name+entry)) (cdr name+entry)))
(list)))) (list))))
(set! cons* (set! cons*
@ -108,22 +108,22 @@
(define <cell:keyword> 4) (define <cell:keyword> 4)
(define <cell:string> 10) (define <cell:string> 10)
(define (newline . rest) (core:stderr (list->string (list (integer->char 10))))) (define (newline . rest) (core:display (list->string (list (integer->char 10)))))
(define (display x . rest) (core:stderr x)) (define (display x . rest) core:display)
(define (list->symbol lst) (make-symbol lst)) (define (list->symbol lst) (core:lookup-symbol lst))
(define (symbol->list s) (define (symbol->list s)
(core:car s)) (core:car s))
(define (list->string lst) (define (list->string lst)
(make-cell <cell:string> lst 0)) (core:make-cell <cell:string> lst 0))
(define (integer->char x) (define (integer->char x)
(make-cell <cell:character> 0 x)) (core:make-cell <cell:character> 0 x))
(define (symbol->keyword s) (define (symbol->keyword s)
(make-cell <cell:keyword> (symbol->list s) 0)) (core:make-cell <cell:keyword> (symbol->list s) 0))
(define (read) (define (read)
(read-word (read-byte) (list) (current-module))) (read-word (read-byte) (list) (current-module)))
@ -140,9 +140,9 @@
(define-macro (cond . clauses) (define-macro (cond . clauses)
(list (quote if) (pair? clauses) (list (quote if) (pair? clauses)
(list (quote if) (car (car clauses)) (list (quote if) (car (car clauses))
(if (pair? (cdar clauses)) (if (pair? (cdr (car clauses)))
(if (eq? (car (cdar clauses)) (quote =>)) (if (eq? (car (cdr (car clauses))) (quote =>))
(append2 (cdr (cdar clauses)) (list (caar clauses))) (append2 (cdr (cdr (car clauses))) (list (car (car clauses))))
(list (cons (quote lambda) (cons (list) (car clauses))))) (list (cons (quote lambda) (cons (list) (car clauses)))))
(list (cons (quote lambda) (cons (list) (car clauses))))) (list (cons (quote lambda) (cons (list) (car clauses)))))
(if (pair? (cdr clauses)) (if (pair? (cdr clauses))
@ -269,7 +269,16 @@
(cons (f (car lst)) (map1 f (cdr lst))))) (cons (f (car lst)) (map1 f (cdr lst)))))
(define (lookup w a) (define (lookup w a)
(core:lookup (map1 integer->char w) a)) (define (lookup-number c p s n)
(and (> c 47) (< c 58)
(if (null? p) (* s (+ (* n 10) (- c 48)))
(lookup-number (car p) (cdr p) s (+ (* n 10) (- c 48))))))
((lambda (c p)
(or (cond ((and (> c 47) (< c 58)) (lookup-number c p 1 0))
((and (eq? c 45) (pair? p)) (lookup-number (car p) (cdr p) -1 0))
(#t #f))
(core:lookup-symbol (map1 integer->char w))))
(car w) (cdr w)))
(define (read-hash c w a) (define (read-hash c w a)
(cond (cond

8
module/mes/type-0.mes
View File

@ -120,14 +120,14 @@
;;; core: accessors ;;; core: accessors
(define (string . lst) (define (string . lst)
(make-cell <cell:string> lst 0)) (core:make-cell <cell:string> lst 0))
(define (string->list s) (define (string->list s)
(core:car s)) (core:car s))
(define (string->symbol s) (define (string->symbol s)
(if (not (pair? (core:car s))) '() (if (not (pair? (core:car s))) '()
(make-symbol (core:car s)))) (core:lookup-symbol (core:car s))))
(define (symbol->list s) (define (symbol->list s)
(core:car s)) (core:car s))
@ -142,7 +142,7 @@
(apply string (apply append (map1 string->list rest)))) (apply string (apply append (map1 string->list rest))))
(define (integer->char x) (define (integer->char x)
(make-cell <cell:character> 0 x)) (core:make-cell <cell:character> 0 x))
(define (char->integer x) (define (char->integer x)
(make-cell <cell:number> 0 x)) (core:make-cell <cell:number> 0 x))

133
posix.c
View File

@ -97,139 +97,6 @@ string_to_cstring (SCM s)
return buf; return buf;
} }
int g_depth;
SCM
display_helper (SCM x, int cont, char* sep)
{
gputs (sep);
if (g_depth == 0) return cell_unspecified;
//FIXME:
//g_depth--;
g_depth = g_depth - 1;
// eputs ("<display>\n");
switch (TYPE (x))
{
case TCHAR:
{
//gputs ("<char>\n");
gputs ("#\\");
putchar (VALUE (x));
break;
}
case TFUNCTION:
{
gputs ("#<procedure ");
///gputs (FUNCTION (x).name ? FUNCTION (x).name : "?");
char *p = "?";
if (FUNCTION (x).name != 0)
p = FUNCTION (x).name;
gputs (p);
gputs ("[");
gputs (itoa (CDR (x)));
gputs (",");
gputs (itoa (x));
gputs ("]>");
break;
}
case TMACRO:
{
gputs ("#<macro ");
display_helper (cdr (x), cont, "");
gputs (">");
break;
}
case TNUMBER:
{
//gputs ("<number>\n");
gputs (itoa (VALUE (x)));
break;
}
case TPAIR:
{
if (!cont) gputs ("(");
if (x && x != cell_nil) display_ (CAR (x));
if (CDR (x) && TYPE (CDR (x)) == TPAIR)
display_helper (CDR (x), 1, " ");
else if (CDR (x) && CDR (x) != cell_nil)
{
if (TYPE (CDR (x)) != TPAIR)
gputs (" . ");
display_ (CDR (x));
}
if (!cont) gputs (")");
break;
}
case TSPECIAL:
#if __NYACC__
// FIXME
//{}
{
SCM t = CAR (x);
while (t && t != cell_nil)
{
putchar (VALUE (CAR (t)));
t = CDR (t);
}
break;
}
#endif
case TSTRING:
#if __NYACC__
// FIXME
{}
#endif
case TSYMBOL:
{
SCM t = CAR (x);
while (t && t != cell_nil)
{
putchar (VALUE (CAR (t)));
t = CDR (t);
}
break;
}
default:
{
//gputs ("<default>\n");
gputs ("<");
gputs (itoa (TYPE (x)));
gputs (":");
gputs (itoa (x));
gputs (">");
break;
}
}
return 0;
}
SCM
display_ (SCM x)
{
g_depth = 5;
return display_helper (x, 0, "");
}
SCM
stderr_ (SCM x)
{
SCM write;
if (TYPE (x) == TSTRING)
eputs (string_to_cstring (x));
#if __GNUC__
else if ((write = assq_ref_env (cell_symbol_write, r0)) != cell_undefined)
apply (assq_ref_env (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0);
#endif
else if (TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL)
eputs (string_to_cstring (x));
else if (TYPE (x) == TNUMBER)
eputs (itoa (VALUE (x)));
else
eputs ("core:stderr: display undefined\n");
return cell_unspecified;
}
SCM SCM
getenv_ (SCM s) ///((name . "getenv")) getenv_ (SCM s) ///((name . "getenv"))
{ {

49
reader.c
View File

@ -1,6 +1,6 @@
/* -*-comment-start: "//";comment-end:""-*- /* -*-comment-start: "//";comment-end:""-*-
* Mes --- Maxwell Equations of Software * Mes --- Maxwell Equations of Software
* Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> * Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
* *
* This file is part of Mes. * This file is part of Mes.
* *
@ -18,6 +18,11 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>. * along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/ */
SCM
___end_of_mes___ ()
{
return 0;
}
SCM SCM
read_input_file_env_ (SCM e, SCM a) read_input_file_env_ (SCM e, SCM a)
@ -86,26 +91,24 @@ read_env (SCM a)
return read_word (getchar (), cell_nil, a); return read_word (getchar (), cell_nil, a);
} }
//MINI_MES SCM
// SCM lookup_ (SCM s, SCM a)
// lookup_ (SCM s, SCM a) {
// { if (isdigit (VALUE (car (s))) || (VALUE (car (s)) == '-' && cdr (s) != cell_nil)) {
// if (isdigit (VALUE (car (s))) || (VALUE (car (s)) == '-' && cdr (s) != cell_nil)) { SCM p = s;
// SCM p = s; int sign = 1;
// int sign = 1; if (VALUE (car (s)) == '-') {
// if (VALUE (car (s)) == '-') { sign = -1;
// sign = -1; p = cdr (s);
// p = cdr (s); }
// } int n = 0;
// int n = 0; while (p != cell_nil && isdigit (VALUE (car (p)))) {
// while (p != cell_nil && isdigit (VALUE (car (p)))) { n *= 10;
// n *= 10; n += VALUE (car (p)) - '0';
// n += VALUE (car (p)) - '0'; p = cdr (p);
// p = cdr (p); }
// } if (p == cell_nil) return MAKE_NUMBER (n * sign);
// if (p == cell_nil) return MAKE_NUMBER (n * sign); }
// }
// SCM x = lookup_symbol_ (s); return lookup_symbol_ (s);
// return x ? x : make_symbol_ (s); }
// }

113
scaffold/cons-mes.c
View File

@ -26,17 +26,6 @@
#define MES_MINI 1 #define MES_MINI 1
#define FIXED_PRIMITIVES 0 #define FIXED_PRIMITIVES 0
#if __GNUC__
#define FIXME_NYACC 1
#define __NYACC__ 0
#define NYACC_CAR
#define NYACC_CDR
#else
#define __NYACC__ 1
#define NYACC_CAR nyacc_car
#define NYACC_CDR nyacc_cdr
#endif
char arena[2000]; char arena[2000];
//char buf0[400]; //char buf0[400];
@ -59,11 +48,7 @@ SCM r2 = 0;
// continuation // continuation
SCM r3 = 0; SCM r3 = 0;
#if __NYACC__ || FIXME_NYACC enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART};
#else
enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
#endif
struct scm { struct scm {
enum type_t type; enum type_t type;
@ -117,11 +102,11 @@ struct function g_functions[5];
int g_function = 0; int g_function = 0;
SCM make_cell (SCM type, SCM car, SCM cdr); SCM make_cell_ (SCM type, SCM car, SCM cdr);
struct function fun_make_cell = {&make_cell,3,"make-cell"}; struct function fun_make_cell_ = {&make_cell_,3,"core:make-cell"};
struct scm scm_make_cell = {TFUNCTION,0,0}; struct scm scm_make_cell_ = {TFUNCTION,0,0};
//, "make-cell", 0}; //, "core:make-cell", 0};
SCM cell_make_cell; SCM cell_make_cell_;
SCM cons (SCM x, SCM y); SCM cons (SCM x, SCM y);
struct function fun_cons = {&cons,2,"cons"}; struct function fun_cons = {&cons,2,"cons"};
@ -153,38 +138,21 @@ SCM cell_cdr;
#define STRING(x) g_cells[x].car #define STRING(x) g_cells[x].car
#define CDR(x) g_cells[x].cdr #define CDR(x) g_cells[x].cdr
#if __GNUC__
//#define CLOSURE(x) g_cells[x].closure
#endif
#define CONTINUATION(x) g_cells[x].cdr #define CONTINUATION(x) g_cells[x].cdr
#if __GNUC__
//#define FUNCTION(x) g_functions[g_cells[x].function]
#endif
#define FUNCTION(x) g_functions[g_cells[x].cdr] #define FUNCTION(x) g_functions[g_cells[x].cdr]
#define VALUE(x) g_cells[x].cdr #define VALUE(x) g_cells[x].cdr
#define VECTOR(x) g_cells[x].cdr #define VECTOR(x) g_cells[x].cdr
#define MAKE_CHAR(n) make_cell (tmp_num_ (CHAR), 0, tmp_num2_ (n)) #define MAKE_CHAR(n) make_cell_ (tmp_num_ (CHAR), 0, tmp_num2_ (n))
//#define MAKE_CONTINUATION(n) make_cell (tmp_num_ (CONTINUATION), n, g_stack) #define MAKE_NUMBER(n) make_cell_ (tmp_num_ (NUMBER), 0, tmp_num2_ (n))
#define MAKE_NUMBER(n) make_cell (tmp_num_ (NUMBER), 0, tmp_num2_ (n))
//#define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0)
#define CAAR(x) CAR (CAR (x)) #define CAAR(x) CAR (CAR (x))
// #define CDAR(x) CDR (CAR (x))
#define CADAR(x) CAR (CDR (CAR (x))) #define CADAR(x) CAR (CDR (CAR (x)))
// #define CADDR(x) CAR (CDR (CDR (x)))
// #define CDDDR(x) CDR (CDR (CDR (x)))
#define CDADAR(x) CAR (CDR (CAR (CDR (x)))) #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
#define CADR(x) CAR (CDR (x)) #define CADR(x) CAR (CDR (x))
#define MAKE_STRING(x) make_cell_ (tmp_num_ (TSTRING), x, 0)
#if __NYACC__ || FIXME_NYACC
#define MAKE_STRING(x) make_cell (tmp_num_ (TSTRING), x, 0)
// #else
// #define MAKE_STRING(x) make_cell (tmp_num_ (STRING), x, 0)
#endif
SCM SCM
alloc (int n) alloc (int n)
@ -196,7 +164,7 @@ alloc (int n)
} }
SCM SCM
make_cell (SCM type, SCM car, SCM cdr) make_cell_ (SCM type, SCM car, SCM cdr)
{ {
SCM x = alloc (1); SCM x = alloc (1);
assert (TYPE (type) == NUMBER); assert (TYPE (type) == NUMBER);
@ -239,7 +207,7 @@ cons (SCM x, SCM y)
puts ("\n"); puts ("\n");
#endif #endif
VALUE (tmp_num) = PAIR; VALUE (tmp_num) = PAIR;
return make_cell (tmp_num, x, y); return make_cell_ (tmp_num, x, y);
} }
SCM SCM
@ -464,7 +432,7 @@ SCM
make_symbol_ (SCM s) make_symbol_ (SCM s)
{ {
VALUE (tmp_num) = SYMBOL; VALUE (tmp_num) = SYMBOL;
SCM x = make_cell (tmp_num, s, 0); SCM x = make_cell_ (tmp_num, s, 0);
g_symbols = cons (x, g_symbols); g_symbols = cons (x, g_symbols);
return x; return x;
} }
@ -584,7 +552,7 @@ g_free++;
SCM SCM
make_closure (SCM args, SCM body, SCM a) make_closure (SCM args, SCM body, SCM a)
{ {
return make_cell (tmp_num_ (CLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body))); return make_cell_ (tmp_num_ (CLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
} }
SCM SCM
@ -614,10 +582,10 @@ mes_builtins (SCM a)
// #include "posix.environment.i" // #include "posix.environment.i"
// #include "reader.environment.i" // #include "reader.environment.i"
#else #else
scm_make_cell.cdr = g_function; scm_make_cell_.cdr = g_function;
g_functions[g_function++] = fun_make_cell; g_functions[g_function++] = fun_make_cell_;
cell_make_cell = g_free++; cell_make_cell_ = g_free++;
g_cells[cell_make_cell] = scm_make_cell; g_cells[cell_make_cell_] = scm_make_cell_;
scm_cons.cdr = g_function; scm_cons.cdr = g_function;
g_functions[g_function++] = fun_cons; g_functions[g_function++] = fun_cons;
@ -687,7 +655,7 @@ fill ()
TYPE (11) = TFUNCTION; TYPE (11) = TFUNCTION;
CAR (11) = 0x58585858; CAR (11) = 0x58585858;
// 0 = make_cell // 0 = make_cell_
// 1 = cons // 1 = cons
// 2 = car // 2 = car
CDR (11) = 1; CDR (11) = 1;
@ -729,7 +697,7 @@ display_ (SCM x)
{ {
//puts ("<function>\n"); //puts ("<function>\n");
if (VALUE (x) == 0) if (VALUE (x) == 0)
puts ("make-cell"); puts ("core:make-cell");
if (VALUE (x) == 1) if (VALUE (x) == 1)
puts ("cons"); puts ("cons");
if (VALUE (x) == 2) if (VALUE (x) == 2)
@ -934,49 +902,6 @@ simple_bload_env (SCM a) ///((internal))
return r2; return r2;
} }
char string_to_cstring_buf[1024];
char const*
string_to_cstring (SCM s)
{
//static char buf[1024];
//char *p = buf;
char *p = string_to_cstring_buf;
s = STRING(s);
while (s != cell_nil)
{
*p++ = VALUE (car (s));
s = cdr (s);
}
*p = 0;
//return buf;
return string_to_cstring_buf;
}
SCM
stderr_ (SCM x)
{
//SCM write;
#if __NYACC__ || FIXME_NYACC
if (TYPE (x) == TSTRING)
// #else
// if (TYPE (x) == STRING)
#endif
eputs (string_to_cstring (x));
// else if ((write = assq_ref_env (cell_symbol_write, r0)) != cell_undefined)
// apply (assq_ref_env (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0);
#if __NYACC__ || FIXME_NYACC
else if (TYPE (x) == SPECIAL || TYPE (x) == TSTRING || TYPE (x) == SYMBOL)
// #else
// else if (TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL)
#endif
eputs (string_to_cstring (x));
else if (TYPE (x) == NUMBER)
eputs (itoa (VALUE (x)));
else
eputs ("display: undefined\n");
return cell_unspecified;
}
int int
main (int argc, char *argv[]) main (int argc, char *argv[])
{ {

11
scaffold/micro-mes.c
View File

@ -26,16 +26,6 @@
#define MES_MINI 1 #define MES_MINI 1
#if __GNUC__
#define __NYACC__ 0
#define NYACC
#define NYACC2
#else
#define __NYACC__ 1
#define NYACC nyacc
#define NYACC2 nyacc2
#endif
typedef int SCM; typedef int SCM;
#if __GNUC__ #if __GNUC__
@ -91,7 +81,6 @@ main (int argc, char *argv[])
push_cc (r2, cell_unspecified, r0, cell_unspecified); push_cc (r2, cell_unspecified, r0, cell_unspecified);
r3 = cell_vm_begin; r3 = cell_vm_begin;
r1 = eval_apply (); r1 = eval_apply ();
stderr_ (r1);
eputs ("\n"); eputs ("\n");
gc (g_stack); gc (g_stack);

650
scaffold/mini-mes.c
View File

@ -23,28 +23,9 @@
#endif #endif
#define assert(x) ((x) ? (void)0 : assert_fail (#x)) #define assert(x) ((x) ? (void)0 : assert_fail (#x))
#if __MESC__
//void *g_malloc_base = 0;
char *g_malloc_base = 0;
// int ungetc_char = -1;
// char ungetc_buf[2];
#endif
#define MES_MINI 1 #define MES_MINI 1
#define FIXED_PRIMITIVES 1 #define FIXED_PRIMITIVES 1
#if __GNUC__
#define FIXME_NYACC 1
#define __NYACC__ 0
#define NYACC_CAR
#define NYACC_CDR
#else
#define __NYACC__ 1
#define NYACC_CAR nyacc_car
#define NYACC_CDR nyacc_cdr
#endif
//int ARENA_SIZE = 4000000; //int ARENA_SIZE = 4000000;
int ARENA_SIZE = 1000000000; int ARENA_SIZE = 1000000000;
char *arena = 0; char *arena = 0;
@ -80,16 +61,14 @@ struct function {
char *name; char *name;
}; };
//struct scm *g_cells = arena;
int *foobar = 0;
#if __GNUC__ #if __GNUC__
struct scm *g_cells; struct scm *g_cells = 0;
#else
struct scm *g_cells = foobar;
#endif
//FIXME
//struct scm *g_news = 0; //struct scm *g_news = 0;
#else
int *foobar = 0;
struct scm *g_cells = foobar;
//struct scm *g_news = foobar;
#endif
struct scm scm_nil = {TSPECIAL, "()",0}; struct scm scm_nil = {TSPECIAL, "()",0};
struct scm scm_f = {TSPECIAL, "#f",0}; struct scm scm_f = {TSPECIAL, "#f",0};
@ -201,29 +180,24 @@ int g_function = 0;
#define VALUE(x) g_cells[x].cdr #define VALUE(x) g_cells[x].cdr
#define VECTOR(x) g_cells[x].cdr #define VECTOR(x) g_cells[x].cdr
#define MAKE_CHAR(n) make_cell (tmp_num_ (TCHAR), 0, tmp_num2_ (n)) #define MAKE_CHAR(n) make_cell_ (tmp_num_ (TCHAR), 0, tmp_num2_ (n))
#define MAKE_CONTINUATION(n) make_cell (tmp_num_ (TCONTINUATION), n, g_stack) #define MAKE_CONTINUATION(n) make_cell_ (tmp_num_ (TCONTINUATION), n, g_stack)
#define MAKE_NUMBER(n) make_cell (tmp_num_ (TNUMBER), 0, tmp_num2_ (n)) #define MAKE_NUMBER(n) make_cell_ (tmp_num_ (TNUMBER), 0, tmp_num2_ (n))
//#define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0)
#define CAAR(x) CAR (CAR (x)) #define CAAR(x) CAR (CAR (x))
#define CADR(x) CAR (CDR (x))
#define CDAR(x) CDR (CAR (x)) #define CDAR(x) CDR (CAR (x))
#define CDDR(x) CDR (CDR (x))
#define CADAR(x) CAR (CDR (CAR (x))) #define CADAR(x) CAR (CDR (CAR (x)))
#define CADDR(x) CAR (CDR (CDR (x))) #define CADDR(x) CAR (CDR (CDR (x)))
// #define CDDDR(x) CDR (CDR (CDR (x)))
#define CDADAR(x) CAR (CDR (CAR (CDR (x)))) #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
#define CADR(x) CAR (CDR (x))
#define MAKE_STRING(x) make_cell (tmp_num_ (TSTRING), x, 0) #define MAKE_STRING(x) make_cell_ (tmp_num_ (TSTRING), x, 0)
SCM SCM
alloc (int n) alloc (int n)
{ {
#if 1
//__GNUC__
assert (g_free + n < ARENA_SIZE); assert (g_free + n < ARENA_SIZE);
#endif
SCM x = g_free; SCM x = g_free;
g_free += n; g_free += n;
return x; return x;
@ -232,7 +206,21 @@ alloc (int n)
#define DEBUG 0 #define DEBUG 0
SCM SCM
make_cell (SCM type, SCM car, SCM cdr) tmp_num_ (int x)
{
VALUE (tmp_num) = x;
return tmp_num;
}
SCM
tmp_num2_ (int x)
{
VALUE (tmp_num2) = x;
return tmp_num2;
}
SCM
make_cell_ (SCM type, SCM car, SCM cdr)
{ {
SCM x = alloc (1); SCM x = alloc (1);
#if __GNUC__ #if __GNUC__
@ -254,25 +242,84 @@ make_cell (SCM type, SCM car, SCM cdr)
return x; return x;
} }
SCM SCM
tmp_num_ (int x) make_symbol_ (SCM s) ///((internal))
{ {
VALUE (tmp_num) = x; VALUE (tmp_num) = TSYMBOL;
return tmp_num; SCM x = make_cell_ (tmp_num, s, 0);
g_symbols = cons (x, g_symbols);
return x;
} }
SCM SCM
tmp_num2_ (int x) lookup_symbol_ (SCM s)
{ {
VALUE (tmp_num2) = x; SCM x = g_symbols;
return tmp_num2; while (x) {
//if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break;
if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) goto dun;
x = cdr (x);
}
dun:
if (x) x = car (x);
if (!x) x = make_symbol_ (s);
return x;
}
SCM
list_of_char_equal_p (SCM a, SCM b) ///((internal))
{
while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) {
#if __GNUC__
assert (TYPE (car (a)) == TCHAR);
assert (TYPE (car (b)) == TCHAR);
#endif
a = cdr (a);
b = cdr (b);
}
return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
}
SCM
type_ (SCM x)
{
return MAKE_NUMBER (TYPE (x));
}
SCM
car_ (SCM x)
{
return (TYPE (x) != TCONTINUATION
&& (TYPE (CAR (x)) == TPAIR // FIXME: this is weird
|| TYPE (CAR (x)) == TREF
|| TYPE (CAR (x)) == TSPECIAL
|| TYPE (CAR (x)) == TSYMBOL
|| TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
}
SCM
cdr_ (SCM x)
{
return (TYPE (CDR (x)) == TPAIR
|| TYPE (CDR (x)) == TREF
|| TYPE (CAR (x)) == TSPECIAL
|| TYPE (CDR (x)) == TSYMBOL
|| TYPE (CDR (x)) == TSTRING) ? CDR (x) : MAKE_NUMBER (CDR (x));
}
SCM
arity_ (SCM x)
{
assert (TYPE (x) == TFUNCTION);
return MAKE_NUMBER (FUNCTION (x).arity);
} }
SCM SCM
cons (SCM x, SCM y) cons (SCM x, SCM y)
{ {
VALUE (tmp_num) = TPAIR; VALUE (tmp_num) = TPAIR;
return make_cell (tmp_num, x, y); return make_cell_ (tmp_num, x, y);
} }
SCM SCM
@ -325,30 +372,17 @@ eq_p (SCM x, SCM y)
} }
SCM SCM
type_ (SCM x) values (SCM x) ///((arity . n))
{ {
return MAKE_NUMBER (TYPE (x)); SCM v = cons (0, x);
TYPE (v) = TVALUES;
return v;
} }
SCM SCM
car_ (SCM x) acons (SCM key, SCM value, SCM alist)
{ {
return (TYPE (x) != TCONTINUATION return cons (cons (key, value), alist);
&& (TYPE (CAR (x)) == TPAIR // FIXME: this is weird
|| TYPE (CAR (x)) == TREF
|| TYPE (CAR (x)) == TSPECIAL
|| TYPE (CAR (x)) == TSYMBOL
|| TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
}
SCM
cdr_ (SCM x)
{
return (TYPE (CDR (x)) == TPAIR
|| TYPE (CDR (x)) == TREF
|| TYPE (CAR (x)) == TSPECIAL
|| TYPE (CDR (x)) == TSYMBOL
|| TYPE (CDR (x)) == TSTRING) ? CDR (x) : MAKE_NUMBER (CDR (x));
} }
SCM SCM
@ -370,7 +404,9 @@ error (SCM key, SCM x)
SCM throw; SCM throw;
if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined) if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
return apply (throw, cons (key, cons (x, cell_nil)), r0); return apply (throw, cons (key, cons (x, cell_nil)), r0);
eputs ("error"); display_ (key);
puts (": ");
display_ (x);
assert (0); assert (0);
} }
@ -380,7 +416,7 @@ assert_defined (SCM x, SCM e) ///((internal))
if (e != cell_undefined) return e; if (e != cell_undefined) return e;
// error (cell_symbol_unbound_variable, x); // error (cell_symbol_unbound_variable, x);
eputs ("unbound variable: "); eputs ("unbound variable: ");
display_ (x); display_error_ (x);
eputs ("\n"); eputs ("\n");
exit (33); exit (33);
return e; return e;
@ -416,7 +452,7 @@ check_formals (SCM f, SCM formals, SCM args) ///((internal))
eputs (", got: "); eputs (", got: ");
eputs (itoa (alen)); eputs (itoa (alen));
eputs ("\n"); eputs ("\n");
display_ (f); display_error_ (f);
SCM e = MAKE_STRING (cstring_to_list (buf)); SCM e = MAKE_STRING (cstring_to_list (buf));
return error (cell_symbol_wrong_number_of_args, cons (e, f)); return error (cell_symbol_wrong_number_of_args, cons (e, f));
} }
@ -443,12 +479,12 @@ check_apply (SCM f, SCM e) ///((internal))
char buf = "TODO:check_apply"; char buf = "TODO:check_apply";
// sprintf (buf, "cannot apply: %s:", type); // sprintf (buf, "cannot apply: %s:", type);
// fprintf (stderr, " ["); // fprintf (stderr, " [");
// stderr_ (e); // display_error_ (e);
// fprintf (stderr, "]\n"); // fprintf (stderr, "]\n");
eputs ("cannot apply: "); eputs ("cannot apply: ");
eputs (type); eputs (type);
eputs ("["); eputs ("[");
display_ (e); display_error_ (e);
eputs ("]\n"); eputs ("]\n");
SCM e = MAKE_STRING (cstring_to_list (buf)); SCM e = MAKE_STRING (cstring_to_list (buf));
return error (cell_symbol_wrong_type_arg, cons (e, f)); return error (cell_symbol_wrong_type_arg, cons (e, f));
@ -504,18 +540,12 @@ call (SCM fn, SCM x)
if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1) if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
&& x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES) && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
x = cons (CAR (x), cons (CDADAR (x), CDR (x))); x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
#if 0
eputs ("call: ");
if (FUNCTION (fn).name) eputs (FUNCTION (fn).name);
else eputs (itoa (CDR (fn)));
eputs ("\n");
#endif
switch (FUNCTION (fn).arity) switch (FUNCTION (fn).arity)
{ {
case 0: {return (FUNCTION (fn).function) ();} case 0: {return (FUNCTION (fn).function) ();}
case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));} case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (CAR (x));}
case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));} case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x));}
case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));} case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x), car (CDDR (x)));}
case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);} case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);} default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
} }
@ -577,29 +607,17 @@ call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
} }
SCM SCM
make_closure (SCM args, SCM body, SCM a) 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))); return make_cell_ (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
} }
SCM SCM
lookup_macro (SCM x, SCM a) lookup_macro_ (SCM x, SCM a) ///((internal))
{ {
if (TYPE (x) != TSYMBOL) return cell_f; if (TYPE (x) != TSYMBOL) return cell_f;
SCM m = assq_ref_env (x, a); SCM m = assq_ref_env (x, a);
#if 0 if (TYPE (m) == TMACRO) return MACRO (m);
if (TYPE (m) == TMACRO)
{
fputs ("XXmacro: ", 1);
fputs ("[", 1);
fputs (itoa (m), 1);
fputs ("]: ", 1);
display_ (m);
fputs ("\n", 1);
}
#endif
if (TYPE (m) == TMACRO) return MACRO (m);
return cell_f; return cell_f;
} }
@ -616,11 +634,6 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
return cell_unspecified; return cell_unspecified;
} }
SCM caar (SCM x) {return car (car (x));}
SCM cadr (SCM x) {return car (cdr (x));}
SCM cdar (SCM x) {return cdr (car (x));}
SCM cddr (SCM x) {return cdr (cdr (x));}
SCM gc_pop_frame (); //((internal)) SCM gc_pop_frame (); //((internal))
SCM SCM
@ -684,13 +697,13 @@ eval_apply ()
} }
case TCLOSURE: case TCLOSURE:
{ {
SCM cl = CLOSURE (car (r1)); SCM cl = CLOSURE (CAR (r1));
SCM formals = cadr (cl); SCM formals = CADR (cl);
SCM body = cddr (cl); SCM body = CDDR (cl);
SCM aa = cdar (cl); SCM aa = CDAR (cl);
aa = cdr (aa); aa = CDR (aa);
check_formals (car (r1), formals, cdr (r1)); check_formals (CAR (r1), formals, CDR (r1));
SCM p = pairlis (formals, cdr (r1), aa); SCM p = pairlis (formals, CDR (r1), aa);
call_lambda (body, p, aa, r0); call_lambda (body, p, aa, r0);
goto begin; goto begin;
} }
@ -699,7 +712,7 @@ eval_apply ()
x = r1; x = r1;
g_stack = CONTINUATION (CAR (r1)); g_stack = CONTINUATION (CAR (r1));
gc_pop_frame (); gc_pop_frame ();
r1 = cadr (x); r1 = CADR (x);
goto eval_apply; goto eval_apply;
} }
case TSPECIAL: case TSPECIAL:
@ -740,12 +753,12 @@ eval_apply ()
} }
case TPAIR: case TPAIR:
{ {
switch (caar (r1)) switch (CAAR (r1))
{ {
case cell_symbol_lambda: case cell_symbol_lambda:
{ {
SCM formals = cadr (car (r1)); SCM formals = CADR (car (r1));
SCM body = cddr (car (r1)); SCM body = CDDR (car (r1));
SCM p = pairlis (formals, cdr (r1), r0); SCM p = pairlis (formals, cdr (r1), r0);
check_formals (r1, formals, cdr (r1)); check_formals (r1, formals, cdr (r1));
call_lambda (body, p, p, r0); call_lambda (body, p, p, r0);
@ -799,27 +812,27 @@ eval_apply ()
#endif // FIXED_PRIMITIVES #endif // FIXED_PRIMITIVES
case cell_symbol_quote: 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_begin: goto begin;
case cell_symbol_lambda: case cell_symbol_lambda:
{ {
r1 = make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0)); r1 = make_closure_ (CADR (r1), CDDR (r1), assq (cell_closure, r0));
goto vm_return; 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: case cell_symbol_set_x:
{ {
push_cc (car (cddr (r1)), r1, r0, cell_vm_eval_set_x); push_cc (car (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
goto eval; goto eval;
eval_set_x: eval_set_x:
x = r2; x = r2;
r1 = set_env_x (cadr (x), r1, r0); r1 = set_env_x (CADR (x), r1, r0);
goto vm_return; goto vm_return;
} }
case cell_vm_macro_expand: case cell_vm_macro_expand:
{ {
push_cc (cadr (r1), r1, r0, cell_vm_return); push_cc (CADR (r1), r1, r0, cell_vm_return);
goto macro_expand; goto macro_expand;
} }
default: { default: {
@ -855,17 +868,9 @@ eval_apply ()
SCM expanders; SCM expanders;
macro_expand: macro_expand:
if (TYPE (r1) == TPAIR if (TYPE (r1) == TPAIR
&& (macro = lookup_macro (car (r1), r0)) != cell_f) && (macro = lookup_macro_ (car (r1), r0)) != cell_f)
{ {
r1 = cons (macro, CDR (r1)); r1 = cons (macro, CDR (r1));
#if 0
puts ("macro: ");
display_ (macro);
puts ("\n");
puts ("r1: ");
display_ (r1);
puts ("\n");
#endif
goto apply; goto apply;
} }
else if (TYPE (r1) == TPAIR else if (TYPE (r1) == TPAIR
@ -886,9 +891,9 @@ eval_apply ()
while (r1 != cell_nil) { while (r1 != cell_nil) {
if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR) if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
{ {
if (caar (r1) == cell_symbol_begin) if (CAAR (r1) == cell_symbol_begin)
r1 = append2 (cdar (r1), cdr (r1)); r1 = append2 (CDAR (r1), cdr (r1));
else if (caar (r1) == cell_symbol_primitive_load) else if (CAAR (r1) == cell_symbol_primitive_load)
{ {
push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file); push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
goto apply; goto apply;
@ -899,11 +904,6 @@ eval_apply ()
if (CDR (r1) == cell_nil) if (CDR (r1) == cell_nil)
{ {
r1 = car (r1); r1 = car (r1);
#if 0
puts ("begin: ");
display_ (r1);
puts ("\n");
#endif
goto eval; goto eval;
} }
push_cc (CAR (r1), r1, r0, cell_vm_begin2); push_cc (CAR (r1), r1, r0, cell_vm_begin2);
@ -923,12 +923,12 @@ eval_apply ()
r1 = r2; r1 = r2;
if (x != cell_f) if (x != cell_f)
{ {
r1 = cadr (r1); r1 = CADR (r1);
goto eval; goto eval;
} }
if (cddr (r1) != cell_nil) if (CDDR (r1) != cell_nil)
{ {
r1 = car (cddr (r1)); r1 = car (CDDR (r1));
goto eval; goto eval;
} }
r1 = cell_unspecified; r1 = cell_unspecified;
@ -956,7 +956,7 @@ eval_apply ()
call_with_values2: call_with_values2:
if (TYPE (r1) == TVALUES) if (TYPE (r1) == TVALUES)
r1 = CDR (r1); r1 = CDR (r1);
r1 = cons (cadr (r2), r1); r1 = cons (CADR (r2), r1);
goto apply; goto apply;
vm_return: vm_return:
@ -969,11 +969,11 @@ eval_apply ()
SCM SCM
gc_peek_frame () ///((internal)) gc_peek_frame () ///((internal))
{ {
SCM frame = car (g_stack); SCM frame = CAR (g_stack);
r1 = car (frame); r1 = CAR (frame);
r2 = cadr (frame); r2 = CADR (frame);
r3 = car (cddr (frame)); r3 = CAR (CDDR (frame));
r0 = cadr (cddr (frame)); r0 = CADR (CDDR (frame));
return frame; return frame;
} }
@ -1009,86 +1009,6 @@ make_tmps (struct scm* cells)
return 0; return 0;
} }
SCM
make_symbol_ (SCM s)
{
VALUE (tmp_num) = TSYMBOL;
SCM x = make_cell (tmp_num, s, 0);
g_symbols = cons (x, g_symbols);
return x;
}
SCM
list_of_char_equal_p (SCM a, SCM b)
{
while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) {
#if __GNUC__
assert (TYPE (car (a)) == TCHAR);
assert (TYPE (car (b)) == TCHAR);
#endif
a = cdr (a);
b = cdr (b);
}
return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
}
SCM
lookup_symbol_ (SCM s)
{
SCM x = g_symbols;
while (x) {
//if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break;
if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) goto dun;
x = cdr (x);
}
dun:
if (x) x = car (x);
return x;
}
SCM
make_symbol (SCM s)
{
SCM x = lookup_symbol_ (s);
return x ? x : make_symbol_ (s);
}
//MINI_MES reader.c
SCM
lookup_ (SCM s, SCM a)
{
if (isdigit (VALUE (car (s))) || (VALUE (car (s)) == '-' && cdr (s) != cell_nil)) {
SCM p = s;
int sign = 1;
if (VALUE (car (s)) == '-') {
sign = -1;
p = cdr (s);
}
int n = 0;
while (p != cell_nil && isdigit (VALUE (car (p)))) {
#if __GNUC__
//FIXME
n *= 10;
n += VALUE (car (p)) - '0';
#else
n = n * 10;
n = n + VALUE (car (p)) - '0';
#endif
p = cdr (p);
}
if (p == cell_nil) return MAKE_NUMBER (n * sign);
}
SCM x = lookup_symbol_ (s);
return x ? x : make_symbol_ (s);
}
SCM
acons (SCM key, SCM value, SCM alist)
{
return cons (cons (key, value), alist);
}
// Posix // Posix
int int
ungetchar (int c) ungetchar (int c)
@ -1158,148 +1078,6 @@ string_to_cstring (SCM s)
return string_to_cstring_buf; return string_to_cstring_buf;
} }
int g_depth;
SCM
display_helper (SCM x, int cont, char* sep)
{
puts (sep);
if (g_depth == 0) return cell_unspecified;
//FIXME:
//g_depth--;
g_depth = g_depth - 1;
// eputs ("<display>\n");
switch (TYPE (x))
{
case TCHAR:
{
//puts ("<char>\n");
puts ("#\\");
putchar (VALUE (x));
break;
}
case TFUNCTION:
{
puts ("#<procedure ");
///puts (FUNCTION (x).name ? FUNCTION (x).name : "?");
char *p = "?";
if (FUNCTION (x).name != 0)
p = FUNCTION (x).name;
puts (p);
puts ("[");
puts (itoa (CDR (x)));
puts (",");
puts (itoa (x));
puts ("]>");
break;
}
case TMACRO:
{
puts ("#<macro ");
display_helper (cdr (x), cont, "");
puts (">");
break;
}
case TNUMBER:
{
//puts ("<number>\n");
puts (itoa (VALUE (x)));
break;
}
case TPAIR:
{
if (!cont) puts ("(");
if (x && x != cell_nil) display_ (CAR (x));
if (CDR (x) && TYPE (CDR (x)) == TPAIR)
display_helper (CDR (x), 1, " ");
else if (CDR (x) && CDR (x) != cell_nil)
{
if (TYPE (CDR (x)) != TPAIR)
puts (" . ");
display_ (CDR (x));
}
if (!cont) puts (")");
break;
}
case TSPECIAL:
#if __NYACC__
// FIXME
//{}
{
SCM t = CAR (x);
while (t && t != cell_nil)
{
putchar (VALUE (CAR (t)));
t = CDR (t);
}
break;
}
#endif
case TSTRING:
#if __NYACC__
// FIXME
//{}
{
SCM t = CAR (x);
while (t && t != cell_nil)
{
putchar (VALUE (CAR (t)));
t = CDR (t);
}
break;
}
#endif
case TSYMBOL:
{
SCM t = CAR (x);
while (t && t != cell_nil)
{
putchar (VALUE (CAR (t)));
t = CDR (t);
}
break;
}
default:
{
//puts ("<default>\n");
puts ("<");
puts (itoa (TYPE (x)));
puts (":");
puts (itoa (x));
puts (">");
break;
}
}
return 0;
}
SCM
display_ (SCM x)
{
g_depth = 5;
return display_helper (x, 0, "");
}
SCM
stderr_ (SCM x)
{
SCM write;
if (TYPE (x) == TSTRING)
eputs (string_to_cstring (x));
#if __GNUC__
else if ((write = assq_ref_env (cell_symbol_write, r0)) != cell_undefined)
apply (assq_ref_env (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0);
#endif
else if (TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL)
eputs (string_to_cstring (x));
else if (TYPE (x) == TNUMBER)
eputs (itoa (VALUE (x)));
else
eputs ("core:stderr: display undefined\n");
return cell_unspecified;
}
SCM SCM
getenv_ (SCM s) ///((name . "getenv")) getenv_ (SCM s) ///((name . "getenv"))
{ {
@ -1513,6 +1291,135 @@ ash (SCM n, SCM count)
// Lib [rest of] // Lib [rest of]
int g_depth;
SCM
display_helper (SCM x, int cont, char* sep, int fd)
{
fputs (sep, fd);
if (g_depth == 0) return cell_unspecified;
g_depth = g_depth - 1;
switch (TYPE (x))
{
case TCHAR:
{
fputs ("#\\", fd);
putc (VALUE (x), fd);
break;
}
case TFUNCTION:
{
fputs ("#<procedure ", fd);
char *p = "?";
if (FUNCTION (x).name != 0)
p = FUNCTION (x).name;
fputs (p, fd);
fputs ("[", fd);
fputs (itoa (CDR (x)), fd);
fputs (",", fd);
fputs (itoa (x), fd);
fputs ("]>", fd);
break;
}
case TMACRO:
{
fputs ("#<macro ", fd);
display_helper (cdr (x), cont, "", fd);
fputs (">", fd);
break;
}
case TNUMBER:
{
fputs (itoa (VALUE (x)), fd);
break;
}
case TPAIR:
{
if (!cont) fputs ("(", fd);
if (x && x != cell_nil) fdisplay_ (CAR (x), fd);
if (CDR (x) && TYPE (CDR (x)) == TPAIR)
display_helper (CDR (x), 1, " ", fd);
else if (CDR (x) && CDR (x) != cell_nil)
{
if (TYPE (CDR (x)) != TPAIR)
fputs (" . ", fd);
fdisplay_ (CDR (x), fd);
}
if (!cont) fputs (")", fd);
break;
}
case TSPECIAL:
#if __NYACC__
// FIXME
//{}
{
SCM t = CAR (x);
while (t && t != cell_nil)
{
putc (VALUE (CAR (t)), fd);
t = CDR (t);
}
break;
}
#endif
case TSTRING:
#if __NYACC__
// FIXME
{
SCM t = CAR (x);
while (t && t != cell_nil)
{
putc (VALUE (CAR (t)), fd);
t = CDR (t);
}
break;
}
#endif
case TSYMBOL:
{
SCM t = CAR (x);
while (t && t != cell_nil)
{
putc (VALUE (CAR (t)), fd);
t = CDR (t);
}
break;
}
default:
{
fputs ("<", fd);
fputs (itoa (TYPE (x)), fd);
fputs (":", fd);
fputs (itoa (x), fd);
fputs (">", fd);
break;
}
}
return 0;
}
SCM
display_ (SCM x)
{
g_depth = 5;
return display_helper (x, 0, "", STDOUT);
}
SCM
display_error_ (SCM x)
{
g_depth = 5;
return display_helper (x, 0, "", STDERR);
}
SCM
fdisplay_ (SCM x, int fd) ///((internal))
{
g_depth = 5;
return display_helper (x, 0, "", fd);
}
SCM SCM
exit_ (SCM x) ///((name . "exit")) exit_ (SCM x) ///((name . "exit"))
{ {
@ -1528,21 +1435,6 @@ append (SCM x) ///((arity . n))
return append2 (car (x), append (cdr (x))); return append2 (car (x), append (cdr (x)));
} }
SCM
values (SCM x) ///((arity . n))
{
SCM v = cons (0, x);
TYPE (v) = TVALUES;
return v;
}
SCM
arity_ (SCM x)
{
assert (TYPE (x) == TFUNCTION);
return MAKE_NUMBER (FUNCTION (x).arity);
}
SCM SCM
xassq (SCM x, SCM a) ///for speed in core only xassq (SCM x, SCM a) ///for speed in core only
{ {

2
scaffold/tiny-mes.c
View File

@ -198,7 +198,7 @@ display_ (SCM x)
{ {
//puts ("<function>\n"); //puts ("<function>\n");
if (VALUE (x) == 0) if (VALUE (x) == 0)
puts ("make-cell"); puts ("core:make-cell");
if (VALUE (x) == 1) if (VALUE (x) == 1)
puts ("cons"); puts ("cons");
if (VALUE (x) == 2) if (VALUE (x) == 2)

12
tests/gc-0.test
View File

@ -26,15 +26,15 @@ exit $?
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>. ;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(define zero (make-cell 2 0 0)) (define zero (core:make-cell 2 0 0))
(define one (make-cell 2 0 1)) (define one (core:make-cell 2 0 1))
(define pair (make-cell 3 zero one)) (define pair (core:make-cell 3 zero one))
(define zero-list (make-cell 3 zero '())) (define zero-list (core:make-cell 3 zero '()))
(define v (make-vector 1)) (define v (make-vector 1))
(display v) (newline) (display v) (newline)
(vector-set! v 0 88) (vector-set! v 0 88)
(define zero-v-list (make-cell 3 v zero-list)) (define zero-v-list (core:make-cell 3 v zero-list))
(define list (make-cell 3 (make-cell 3 zero one) zero-v-list)) (define list (core:make-cell 3 (make-cell 3 zero one) zero-v-list))
(display "list: ") (display list) (newline) (display "list: ") (display list) (newline)
(display "v: ") (display v) (newline) (display "v: ") (display v) (newline)
(gc) (gc)

20
tests/gc-1.test
View File

@ -26,24 +26,24 @@ exit $?
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>. ;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(define first (make-cell 0 0 #\F)) (newline) (define first (core:make-cell 0 0 #\F)) (newline)
(define one (make-cell 2 0 1)) (define one (core:make-cell 2 0 1))
(display "\n one=") (display one) (newline) (display "\n one=") (display one) (newline)
(define two (make-cell 2 0 2)) (define two (core:make-cell 2 0 2))
(define pair2-nil (make-cell 3 two '())) (define pair2-nil (core:make-cell 3 two '()))
(display "\npair2-nil=") (display pair2-nil) (newline) (display "\npair2-nil=") (display pair2-nil) (newline)
(gc-show) (gc-show)
(define list1-2 (make-cell 3 one pair2-nil)) (define list1-2 (core:make-cell 3 one pair2-nil))
(display "\nlist1-2=") (display list1-2) (newline) (display "\nlist1-2=") (display list1-2) (newline)
(gc-show) (gc-show)
(define three (make-cell 2 0 3)) (define three (core:make-cell 2 0 3))
(define four (make-cell 2 0 4)) (define four (core:make-cell 2 0 4))
(define pair4-nil (make-cell 3 four '())) (define pair4-nil (core:make-cell 3 four '()))
(define list3-4 (make-cell 3 three pair4-nil)) (define list3-4 (core:make-cell 3 three pair4-nil))
(define list1234 (make-cell 3 list1-2 list3-4)) (define list1234 (core:make-cell 3 list1-2 list3-4))
(gc-show) (gc-show)
(gc list1234) (gc list1234)
(gc-show) (gc-show)

4
tests/gc.test
View File

@ -72,10 +72,10 @@ exit $?
(if (= gc-free gc-size) (gc)) (if (= gc-free gc-size) (gc))
((lambda (index) ((lambda (index)
(set! gc-free (+ gc-free 1)) (set! gc-free (+ gc-free 1))
(make-cell 'p index)) (core:make-cell 'p index))
gc-free)) gc-free))
(define (make-cell type . x) (define (core:make-cell type . x)
(cons type (if (pair? x) (car x) '*))) (cons type (if (pair? x) (car x) '*)))
(define (cell-index c) (define (cell-index c)

2
vector.c
View File

@ -24,7 +24,7 @@ make_vector (SCM n)
int k = VALUE (n); int k = VALUE (n);
g_cells[tmp_num].value = TVECTOR; g_cells[tmp_num].value = TVECTOR;
SCM v = alloc (k); SCM v = alloc (k);
SCM x = make_cell (tmp_num, k, v); SCM x = make_cell_ (tmp_num, k, v);
for (int i=0; i<k; i++) g_cells[v+i] = g_cells[vector_entry (cell_unspecified)]; for (int i=0; i<k; i++) g_cells[v+i] = g_cells[vector_entry (cell_unspecified)];
return x; return x;
} }