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

mini-mes: Fully remove reader from core.

Browse source 
* 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
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'
rm -f mes.o
mv 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 $@
# gcc -nostdlib --std=gnu99 -m32 -g -o $@ '-DPREFIX=' '-DVERSION='"$(VERSION)"' $<
gcc -nostdlib -I. --std=gnu99 -m32 -g -I. -o $@ $(CPPFLAGS) $<
rm -f mes.o
chmod +x $@
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 "^builtin_" "")
(regexp-replace "_to_" "->")
(regexp-replace "_x$" "!")
(regexp-replace "_p$" "?"))
(regexp-replace "_p$" "?")
(regexp-replace "___" "***")
(regexp-replace "___" "***"))
(.name f))))
(if (not (string-suffix? "-" name)) name
(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].car = MAKE_STRING (scm_~a.car);\n" (.name f) (.name f)))
(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 (make_symbol (scm_~a.car), ~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 (lookup_symbol_ (scm_~a.car), ~a, a);\n\n" (.name f) (function-cell-name f)))))
(define (snarf-symbols 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:""-*-
* 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.
*
@ -32,6 +32,137 @@
// 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
exit_ (SCM x) ///((name . "exit"))
{
@ -111,7 +242,7 @@ check_apply (SCM f, SCM e) ///((internal))
char buf[1024];
sprintf (buf, "cannot apply: %s:", type);
fprintf (stderr, " [");
stderr_ (e);
display_error_ (e);
fprintf (stderr, "]\n");
SCM e = MAKE_STRING (cstring_to_list (buf));
return error (cell_symbol_wrong_type_arg, cons (e, f));
@ -147,7 +278,7 @@ int
dump ()
{
fputs ("program r2=", stderr);
stderr_ (r2);
display_error_ (r2);
fputs ("\n", stderr);
r1 = g_symbols;
@ -236,21 +367,6 @@ bload_env (SCM a) ///((internal))
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
xassq (SCM x, SCM a) ///for speed in core only
{

2
math.c
View file

@ -1,6 +1,6 @@
/* -*-comment-start: "//";comment-end:""-*-
* 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.
*

306
mes.c
View file

@ -213,19 +213,19 @@ SCM r3 = 0; // continuation
#define NTYPE(x) g_news[x].type
#define CAAR(x) CAR (CAR (x))
#define CADR(x) CAR (CDR (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 CADDR(x) CAR (CDR (CDR (x)))
#define CDDDR(x) CDR (CDR (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_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_REF(n) make_cell (tmp_num_ (TREF), n, 0)
#define MAKE_STRING(x) make_cell (tmp_num_ (TSTRING), x, 0)
#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_NUMBER(n) make_cell_ (tmp_num_ (TNUMBER), 0, tmp_num2_ (n))
#define MAKE_REF(n) make_cell_ (tmp_num_ (TREF), n, 0)
#define MAKE_STRING(x) make_cell_ (tmp_num_ (TSTRING), x, 0)
SCM vm_call (function0_t f, SCM p1, SCM a);
char const* itoa(int);
@ -256,7 +256,7 @@ alloc (int n)
}
SCM
make_cell (SCM type, SCM car, SCM cdr)
make_cell_ (SCM type, SCM car, SCM cdr)
{
SCM x = alloc (1);
assert (TYPE (type) == TNUMBER);
@ -274,11 +274,79 @@ make_cell (SCM type, SCM car, SCM cdr)
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
cons (SCM x, SCM y)
{
g_cells[tmp_num].value = TPAIR;
return make_cell (tmp_num, x, y);
return make_cell_ (tmp_num, x, y);
}
SCM
@ -321,30 +389,17 @@ eq_p (SCM x, SCM y)
}
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
car_ (SCM x)
acons (SCM key, SCM value, SCM alist)
{
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));
return cons (cons (key, value), alist);
}
// MIMI_MES lib.c?
@ -367,6 +422,9 @@ error (SCM key, SCM x)
SCM throw;
if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
return apply (throw, cons (key, cons (x, cell_nil)), r0);
display_error_ (key);
fputs (": ", stderr);
display_error_ (x);
assert (!"error");
}
@ -408,18 +466,12 @@ call (SCM fn, SCM x)
if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
&& x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
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)
{
case 0: return FUNCTION (fn).function0 ();
case 1: return FUNCTION (fn).function1 (car (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 2: return FUNCTION (fn).function2 (car (x), CADR (x));
case 3: return FUNCTION (fn).function3 (car (x), CADR (x), car (CDDR (x)));
case -1: return FUNCTION (fn).functionn (x);
}
@ -430,7 +482,7 @@ SCM
assq (SCM x, SCM 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
@ -438,7 +490,7 @@ assq_ref_env (SCM x, SCM a)
{
x = assq (x, a);
if (x == cell_f) return cell_undefined;
return cdr (x);
return CDR (x);
}
SCM
@ -475,28 +527,16 @@ call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
}
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
lookup_macro (SCM x, SCM a)
lookup_macro_ (SCM x, SCM a) ///((internal))
{
if (TYPE (x) != TSYMBOL) return cell_f;
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);
return cell_f;
}
@ -514,11 +554,6 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
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
eval_apply ()
{
@ -582,9 +617,9 @@ eval_apply ()
case TCLOSURE:
{
SCM cl = CLOSURE (car (r1));
SCM formals = cadr (cl);
SCM body = cddr (cl);
SCM aa = cdar (cl);
SCM formals = CADR (cl);
SCM body = CDDR (cl);
SCM aa = CDAR (cl);
aa = cdr (aa);
check_formals (car (r1), formals, cdr (r1));
SCM p = pairlis (formals, cdr (r1), aa);
@ -596,7 +631,7 @@ eval_apply ()
x = r1;
g_stack = CONTINUATION (CAR (r1));
gc_pop_frame ();
r1 = cadr (x);
r1 = CADR (x);
goto eval_apply;
}
case TSPECIAL:
@ -637,12 +672,12 @@ eval_apply ()
}
case TPAIR:
{
switch (caar (r1))
switch (CAAR (r1))
{
case cell_symbol_lambda:
{
SCM formals = cadr (car (r1));
SCM body = cddr (car (r1));
SCM formals = CADR (car (r1));
SCM body = CDDR (car (r1));
SCM p = pairlis (formals, cdr (r1), r0);
check_formals (r1, formals, cdr (r1));
call_lambda (body, p, p, r0);
@ -696,27 +731,27 @@ eval_apply ()
#endif // 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), assq (cell_closure, r0));
goto vm_return;
}
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);
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 (x), r1, r0);
goto vm_return;
}
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;
}
default: {
@ -752,17 +787,9 @@ eval_apply ()
SCM expanders;
macro_expand:
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));
#if 0
fputs ("macro: ", stdout);
display_ (macro);
fputs ("\n", stdout);
fputs ("r1: ", stdout);
display_ (r1);
fputs ("\n", stdout);
#endif
goto apply;
}
else if (TYPE (r1) == TPAIR
@ -784,9 +811,9 @@ eval_apply ()
while (r1 != cell_nil) {
if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
{
if (caar (r1) == cell_symbol_begin)
r1 = append2 (cdar (r1), cdr (r1));
else if (caar (r1) == cell_symbol_primitive_load)
if (CAAR (r1) == cell_symbol_begin)
r1 = append2 (CDAR (r1), cdr (r1));
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);
goto apply;
@ -797,11 +824,6 @@ eval_apply ()
if (CDR (r1) == cell_nil)
{
r1 = car (r1);
#if 0
fputs ("begin: ", stdout);
display_ (r1);
fputs ("\n", stdout);
#endif
goto eval;
}
push_cc (CAR (r1), r1, r0, cell_vm_begin2);
@ -821,12 +843,12 @@ eval_apply ()
r1 = r2;
if (x != cell_f)
{
r1 = cadr (r1);
r1 = CADR (r1);
goto eval;
}
if (cddr (r1) != cell_nil)
if (CDDR (r1) != cell_nil)
{
r1 = car (cddr (r1));
r1 = car (CDDR (r1));
goto eval;
}
r1 = cell_unspecified;
@ -848,7 +870,7 @@ eval_apply ()
call_with_values2:
if (TYPE (r1) == TVALUES)
r1 = CDR (r1);
r1 = cons (cadr (r2), r1);
r1 = cons (CADR (r2), r1);
goto apply;
vm_return:
@ -863,9 +885,9 @@ gc_peek_frame () ///((internal))
{
SCM frame = car (g_stack);
r1 = car (frame);
r2 = cadr (frame);
r3 = car (cddr (frame));
r0 = cadr (cddr (frame));
r2 = CADR (frame);
r3 = car (CDDR (frame));
r0 = CADR (CDDR (frame));
return frame;
}
@ -892,76 +914,6 @@ apply (SCM f, SCM x, SCM a) ///((internal))
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
make_tmps (struct scm* cells)
{
@ -1041,8 +993,6 @@ mes_symbols () ///((internal))
return a;
}
#define gputs(x) fputs(x,stdout);
SCM
mes_builtins (SCM a) ///((internal))
{
@ -1051,9 +1001,9 @@ mes_builtins (SCM a) ///((internal))
#include "posix.i"
#include "math.i"
#include "lib.i"
#include "reader.i"
#include "vector.i"
#include "gc.i"
#include "reader.i"
#include "gc.environment.i"
#include "lib.environment.i"
@ -1065,18 +1015,18 @@ mes_builtins (SCM a) ///((internal))
if (g_debug)
{
gputs ("functions: ");
gputs (itoa (g_function));
gputs ("\n");
fputs ("functions: ", stderr);
fputs (itoa (g_function), stderr);
fputs ("\n", stderr);
for (int i = 0; i < g_function; i++)
{
gputs ("[");
gputs (itoa (i));
gputs ("]: ");
gputs (g_functions[i].name);
gputs ("\n");
fputs ("[", stderr);
fputs (itoa (i), stderr);
fputs ("]: ", stderr);
fputs (g_functions[i].name, stderr);
fputs ("\n", stderr);
}
gputs ("\n");
fputs ("\n", stderr);
}
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);
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);
r3 = cell_vm_begin;
r1 = eval_apply ();
///stderr_ (r1);
display_ (r1);
display_error_ (r1);
fputs ("", stdout);
gc (g_stack);
#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 INT_MIN -2147483648
#define INT_MAX 2147483647
#define EOF -1
#define STDIN 0
#define STDOUT 1
#define STDERR 2
void
exit (int code)
@ -128,12 +132,17 @@ brk (void *p)
return r;
}
int
putc (int c, int fd)
{
write (fd, (char*)&c, 1);
return 0;
}
int
putchar (int c)
{
//write (STDOUT, s, strlen (s));
//int i = write (STDOUT, s, strlen (s));
write (1, (char*)&c, 1);
write (STDOUT, (char*)&c, 1);
return 0;
}
@ -163,11 +172,6 @@ free (void *p)
//munmap ((void*)p, *n);
}
#define EOF -1
#define STDIN 0
#define STDOUT 1
#define STDERR 2
size_t
strlen (char const* s)
{
@ -186,16 +190,14 @@ strcmp (char const* a, char const* b)
int
eputs (char const* s)
{
//int i = write (STDERR, s, strlen (s));
int i = strlen (s);
write (2, s, i);
write (STDERR, s, i);
return 0;
}
int
fputs (char const* s, int fd)
{
//int i = write (fd, s, strlen (s));
int i = strlen (s);
write (fd, s, i);
return 0;
@ -204,9 +206,8 @@ fputs (char const* s, int fd)
int
puts (char const* s)
{
//int i = write (STDOUT, s, strlen (s));
int i = strlen (s);
write (1, s, i);
write (STDOUT, s, i);
return 0;
}

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

@ -35,6 +35,11 @@
(define (primitive-eval e) (core:eval e (current-module)))
(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)
(list 'assq x '(cddr (current-module))))
@ -107,9 +112,9 @@
(list 'begin
(list 'if (list getenv "MES_DEBUG")
(list 'begin
(list core:stderr "read ")
(list core:stderr file)
(list core:stderr "\n")))
(list core:display-error "read ")
(list core:display-error file)
(list core:display-error "\n")))
(list 'push! '*input-ports* (list current-input-port))
(list 'set-current-input-port (list open-input-file file))
(list 'primitive-load)

21
module/mes/libc.mes
View file

@ -151,8 +151,6 @@ ungetc (int c, int fd)
int
putchar (int c)
{
//write (STDOUT, s, strlen (s));
//int i = write (STDOUT, s, strlen (s));
write (1, (char*)&c, 1);
return 0;
}
@ -161,14 +159,26 @@ putchar (int c)
parse-c99)))
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
(let* ((ast (with-input-from-string
"
int
eputs (char const* s)
{
//write (STDERR, s, strlen (s));
//write (2, s, strlen (s));
int i = strlen (s);
write (2, s, i);
return 0;
@ -199,8 +209,6 @@ fputs (char const* s, int fd)
int
puts (char const* s)
{
//write (STDOUT, s, strlen (s));
//int i = write (STDOUT, s, strlen (s));
int i = strlen (s);
write (1, s, i);
return 0;
@ -323,6 +331,7 @@ realloc (int *p, int size)
assert_fail
ungetc
putchar
putc
eputs
fputs
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
(lambda (e a)
(if (atom? (cadr e)) (cons (cadr e) (core:eval (car (cddr e)) a))
(cons (car (cadr e)) (core:eval (cons (quote lambda) (cons (cdr (cadr e)) (cddr e))) a)))))
(if (atom? (car (cdr e))) (cons (car (cdr e)) (core:eval (car (cdr (cdr e))) a))
(cons (car (car (cdr e))) (core:eval (cons (quote lambda) (cons (cdr (car (cdr e))) (cdr (cdr e)))) a)))))
(set! env:macro
(lambda (name+entry)
(cons
(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))))
(set! cons*
@ -108,22 +108,22 @@
(define <cell:keyword> 4)
(define <cell:string> 10)
(define (newline . rest) (core:stderr (list->string (list (integer->char 10)))))
(define (display x . rest) (core:stderr x))
(define (newline . rest) (core:display (list->string (list (integer->char 10)))))
(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)
(core:car s))
(define (list->string lst)
(make-cell <cell:string> lst 0))
(core:make-cell <cell:string> lst 0))
(define (integer->char x)
(make-cell <cell:character> 0 x))
(core:make-cell <cell:character> 0 x))
(define (symbol->keyword s)
(make-cell <cell:keyword> (symbol->list s) 0))
(core:make-cell <cell:keyword> (symbol->list s) 0))
(define (read)
(read-word (read-byte) (list) (current-module)))
@ -140,9 +140,9 @@
(define-macro (cond . clauses)
(list (quote if) (pair? clauses)
(list (quote if) (car (car clauses))
(if (pair? (cdar clauses))
(if (eq? (car (cdar clauses)) (quote =>))
(append2 (cdr (cdar clauses)) (list (caar clauses)))
(if (pair? (cdr (car clauses)))
(if (eq? (car (cdr (car clauses))) (quote =>))
(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)))))
(if (pair? (cdr clauses))
@ -269,7 +269,16 @@
(cons (f (car lst)) (map1 f (cdr lst)))))
(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)
(cond

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

@ -120,14 +120,14 @@
;;; core: accessors
(define (string . lst)
(make-cell <cell:string> lst 0))
(core:make-cell <cell:string> lst 0))
(define (string->list s)
(core:car s))
(define (string->symbol s)
(if (not (pair? (core:car s))) '()
(make-symbol (core:car s))))
(core:lookup-symbol (core:car s))))
(define (symbol->list s)
(core:car s))
@ -142,7 +142,7 @@
(apply string (apply append (map1 string->list rest))))
(define (integer->char x)
(make-cell <cell:character> 0 x))
(core:make-cell <cell:character> 0 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;
}
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
getenv_ (SCM s) ///((name . "getenv"))
{

49
reader.c
View file

@ -1,6 +1,6 @@
/* -*-comment-start: "//";comment-end:""-*-
* 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.
*
@ -18,6 +18,11 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
SCM
___end_of_mes___ ()
{
return 0;
}
SCM
read_input_file_env_ (SCM e, SCM a)
@ -86,26 +91,24 @@ read_env (SCM a)
return read_word (getchar (), cell_nil, a);
}
//MINI_MES
// 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
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);
// }
return lookup_symbol_ (s);
}

113
scaffold/cons-mes.c
View file

@ -26,17 +26,6 @@
#define MES_MINI 1
#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 buf0[400];
@ -59,11 +48,7 @@ SCM r2 = 0;
// continuation
SCM r3 = 0;
#if __NYACC__ || FIXME_NYACC
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
enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
struct scm {
enum type_t type;
@ -117,11 +102,11 @@ struct function g_functions[5];
int g_function = 0;
SCM make_cell (SCM type, SCM car, SCM cdr);
struct function fun_make_cell = {&make_cell,3,"make-cell"};
struct scm scm_make_cell = {TFUNCTION,0,0};
//, "make-cell", 0};
SCM cell_make_cell;
SCM make_cell_ (SCM type, SCM car, SCM cdr);
struct function fun_make_cell_ = {&make_cell_,3,"core:make-cell"};
struct scm scm_make_cell_ = {TFUNCTION,0,0};
//, "core:make-cell", 0};
SCM cell_make_cell_;
SCM cons (SCM x, SCM y);
struct function fun_cons = {&cons,2,"cons"};
@ -153,38 +138,21 @@ SCM cell_cdr;
#define STRING(x) g_cells[x].car
#define CDR(x) g_cells[x].cdr
#if __GNUC__
//#define CLOSURE(x) g_cells[x].closure
#endif
#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 VALUE(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_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_REF(n) make_cell (tmp_num_ (REF), n, 0)
#define MAKE_CHAR(n) make_cell_ (tmp_num_ (CHAR), 0, tmp_num2_ (n))
#define MAKE_NUMBER(n) make_cell_ (tmp_num_ (NUMBER), 0, tmp_num2_ (n))
#define CAAR(x) CAR (CAR (x))
// #define CDAR(x) 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 CADR(x) CAR (CDR (x))
#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
#define MAKE_STRING(x) make_cell_ (tmp_num_ (TSTRING), x, 0)
SCM
alloc (int n)
@ -196,7 +164,7 @@ alloc (int n)
}
SCM
make_cell (SCM type, SCM car, SCM cdr)
make_cell_ (SCM type, SCM car, SCM cdr)
{
SCM x = alloc (1);
assert (TYPE (type) == NUMBER);
@ -239,7 +207,7 @@ cons (SCM x, SCM y)
puts ("\n");
#endif
VALUE (tmp_num) = PAIR;
return make_cell (tmp_num, x, y);
return make_cell_ (tmp_num, x, y);
}
SCM
@ -464,7 +432,7 @@ SCM
make_symbol_ (SCM s)
{
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);
return x;
}
@ -584,7 +552,7 @@ g_free++;
SCM
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
@ -614,10 +582,10 @@ mes_builtins (SCM a)
// #include "posix.environment.i"
// #include "reader.environment.i"
#else
scm_make_cell.cdr = g_function;
g_functions[g_function++] = fun_make_cell;
cell_make_cell = g_free++;
g_cells[cell_make_cell] = scm_make_cell;
scm_make_cell_.cdr = g_function;
g_functions[g_function++] = fun_make_cell_;
cell_make_cell_ = g_free++;
g_cells[cell_make_cell_] = scm_make_cell_;
scm_cons.cdr = g_function;
g_functions[g_function++] = fun_cons;
@ -687,7 +655,7 @@ fill ()
TYPE (11) = TFUNCTION;
CAR (11) = 0x58585858;
// 0 = make_cell
// 0 = make_cell_
// 1 = cons
// 2 = car
CDR (11) = 1;
@ -729,7 +697,7 @@ display_ (SCM x)
{
//puts ("<function>\n");
if (VALUE (x) == 0)
puts ("make-cell");
puts ("core:make-cell");
if (VALUE (x) == 1)
puts ("cons");
if (VALUE (x) == 2)
@ -934,49 +902,6 @@ simple_bload_env (SCM a) ///((internal))
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
main (int argc, char *argv[])
{

11
scaffold/micro-mes.c
View file

@ -26,16 +26,6 @@
#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;
#if __GNUC__
@ -91,7 +81,6 @@ main (int argc, char *argv[])
push_cc (r2, cell_unspecified, r0, cell_unspecified);
r3 = cell_vm_begin;
r1 = eval_apply ();
stderr_ (r1);
eputs ("\n");
gc (g_stack);

650
scaffold/mini-mes.c
View file

@ -23,28 +23,9 @@
#endif
#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 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 = 1000000000;
char *arena = 0;
@ -80,16 +61,14 @@ struct function {
char *name;
};
//struct scm *g_cells = arena;
int *foobar = 0;
#if __GNUC__
struct scm *g_cells;
#else
struct scm *g_cells = foobar;
#endif
//FIXME
struct scm *g_cells = 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_f = {TSPECIAL, "#f",0};
@ -201,29 +180,24 @@ int g_function = 0;
#define VALUE(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_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_REF(n) make_cell (tmp_num_ (REF), n, 0)
#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_NUMBER(n) make_cell_ (tmp_num_ (TNUMBER), 0, tmp_num2_ (n))
#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 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 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
alloc (int n)
{
#if 1
//__GNUC__
assert (g_free + n < ARENA_SIZE);
#endif
SCM x = g_free;
g_free += n;
return x;
@ -232,7 +206,21 @@ alloc (int n)
#define DEBUG 0
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);
#if __GNUC__
@ -254,25 +242,84 @@ make_cell (SCM type, SCM car, SCM cdr)
return x;
}
SCM
tmp_num_ (int x)
make_symbol_ (SCM s) ///((internal))
{
VALUE (tmp_num) = x;
return tmp_num;
VALUE (tmp_num) = TSYMBOL;
SCM x = make_cell_ (tmp_num, s, 0);
g_symbols = cons (x, g_symbols);
return x;
}
SCM
tmp_num2_ (int x)
lookup_symbol_ (SCM s)
{
VALUE (tmp_num2) = x;
return tmp_num2;
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);
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
cons (SCM x, SCM y)
{
VALUE (tmp_num) = TPAIR;
return make_cell (tmp_num, x, y);
return make_cell_ (tmp_num, x, y);
}
SCM
@ -325,30 +372,17 @@ eq_p (SCM x, SCM y)
}
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
car_ (SCM x)
acons (SCM key, SCM value, SCM alist)
{
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));
return cons (cons (key, value), alist);
}
SCM
@ -370,7 +404,9 @@ error (SCM key, SCM x)
SCM throw;
if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
return apply (throw, cons (key, cons (x, cell_nil)), r0);
eputs ("error");
display_ (key);
puts (": ");
display_ (x);
assert (0);
}
@ -380,7 +416,7 @@ assert_defined (SCM x, SCM e) ///((internal))
if (e != cell_undefined) return e;
// error (cell_symbol_unbound_variable, x);
eputs ("unbound variable: ");
display_ (x);
display_error_ (x);
eputs ("\n");
exit (33);
return e;
@ -416,7 +452,7 @@ check_formals (SCM f, SCM formals, SCM args) ///((internal))
eputs (", got: ");
eputs (itoa (alen));
eputs ("\n");
display_ (f);
display_error_ (f);
SCM e = MAKE_STRING (cstring_to_list (buf));
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";
// sprintf (buf, "cannot apply: %s:", type);
// fprintf (stderr, " [");
// stderr_ (e);
// display_error_ (e);
// fprintf (stderr, "]\n");
eputs ("cannot apply: ");
eputs (type);
eputs ("[");
display_ (e);
display_error_ (e);
eputs ("]\n");
SCM e = MAKE_STRING (cstring_to_list (buf));
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)
&& x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
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)
{
case 0: {return (FUNCTION (fn).function) ();}
case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (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 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (CAR (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 -1: {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
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
lookup_macro (SCM x, SCM a)
lookup_macro_ (SCM x, SCM a) ///((internal))
{
if (TYPE (x) != TSYMBOL) return cell_f;
SCM m = assq_ref_env (x, a);
#if 0
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);
if (TYPE (m) == TMACRO) return MACRO (m);
return cell_f;
}
@ -616,11 +634,6 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
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
@ -684,13 +697,13 @@ eval_apply ()
}
case TCLOSURE:
{
SCM cl = CLOSURE (car (r1));
SCM formals = cadr (cl);
SCM body = cddr (cl);
SCM aa = cdar (cl);
aa = cdr (aa);
check_formals (car (r1), formals, cdr (r1));
SCM p = pairlis (formals, cdr (r1), aa);
SCM cl = CLOSURE (CAR (r1));
SCM formals = CADR (cl);
SCM body = CDDR (cl);
SCM aa = CDAR (cl);
aa = CDR (aa);
check_formals (CAR (r1), formals, CDR (r1));
SCM p = pairlis (formals, CDR (r1), aa);
call_lambda (body, p, aa, r0);
goto begin;
}
@ -699,7 +712,7 @@ eval_apply ()
x = r1;
g_stack = CONTINUATION (CAR (r1));
gc_pop_frame ();
r1 = cadr (x);
r1 = CADR (x);
goto eval_apply;
}
case TSPECIAL:
@ -740,12 +753,12 @@ eval_apply ()
}
case TPAIR:
{
switch (caar (r1))
switch (CAAR (r1))
{
case cell_symbol_lambda:
{
SCM formals = cadr (car (r1));
SCM body = cddr (car (r1));
SCM formals = CADR (car (r1));
SCM body = CDDR (car (r1));
SCM p = pairlis (formals, cdr (r1), r0);
check_formals (r1, formals, cdr (r1));
call_lambda (body, p, p, r0);
@ -799,27 +812,27 @@ eval_apply ()
#endif // 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), assq (cell_closure, r0));
goto vm_return;
}
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);
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 (x), r1, r0);
goto vm_return;
}
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;
}
default: {
@ -855,17 +868,9 @@ eval_apply ()
SCM expanders;
macro_expand:
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));
#if 0
puts ("macro: ");
display_ (macro);
puts ("\n");
puts ("r1: ");
display_ (r1);
puts ("\n");
#endif
goto apply;
}
else if (TYPE (r1) == TPAIR
@ -886,9 +891,9 @@ eval_apply ()
while (r1 != cell_nil) {
if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
{
if (caar (r1) == cell_symbol_begin)
r1 = append2 (cdar (r1), cdr (r1));
else if (caar (r1) == cell_symbol_primitive_load)
if (CAAR (r1) == cell_symbol_begin)
r1 = append2 (CDAR (r1), cdr (r1));
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);
goto apply;
@ -899,11 +904,6 @@ eval_apply ()
if (CDR (r1) == cell_nil)
{
r1 = car (r1);
#if 0
puts ("begin: ");
display_ (r1);
puts ("\n");
#endif
goto eval;
}
push_cc (CAR (r1), r1, r0, cell_vm_begin2);
@ -923,12 +923,12 @@ eval_apply ()
r1 = r2;
if (x != cell_f)
{
r1 = cadr (r1);
r1 = CADR (r1);
goto eval;
}
if (cddr (r1) != cell_nil)
if (CDDR (r1) != cell_nil)
{
r1 = car (cddr (r1));
r1 = car (CDDR (r1));
goto eval;
}
r1 = cell_unspecified;
@ -956,7 +956,7 @@ eval_apply ()
call_with_values2:
if (TYPE (r1) == TVALUES)
r1 = CDR (r1);
r1 = cons (cadr (r2), r1);
r1 = cons (CADR (r2), r1);
goto apply;
vm_return:
@ -969,11 +969,11 @@ eval_apply ()
SCM
gc_peek_frame () ///((internal))
{
SCM frame = car (g_stack);
r1 = car (frame);
r2 = cadr (frame);
r3 = car (cddr (frame));
r0 = cadr (cddr (frame));
SCM frame = CAR (g_stack);
r1 = CAR (frame);
r2 = CADR (frame);
r3 = CAR (CDDR (frame));
r0 = CADR (CDDR (frame));
return frame;
}
@ -1009,86 +1009,6 @@ make_tmps (struct scm* cells)
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
int
ungetchar (int c)
@ -1158,148 +1078,6 @@ string_to_cstring (SCM s)
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
getenv_ (SCM s) ///((name . "getenv"))
{
@ -1513,6 +1291,135 @@ ash (SCM n, SCM count)
// 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
exit_ (SCM x) ///((name . "exit"))
{
@ -1528,21 +1435,6 @@ append (SCM x) ///((arity . n))
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
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");
if (VALUE (x) == 0)
puts ("make-cell");
puts ("core:make-cell");
if (VALUE (x) == 1)
puts ("cons");
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
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(define zero (make-cell 2 0 0))
(define one (make-cell 2 0 1))
(define pair (make-cell 3 zero one))
(define zero-list (make-cell 3 zero '()))
(define zero (core:make-cell 2 0 0))
(define one (core:make-cell 2 0 1))
(define pair (core:make-cell 3 zero one))
(define zero-list (core:make-cell 3 zero '()))
(define v (make-vector 1))
(display v) (newline)
(vector-set! v 0 88)
(define zero-v-list (make-cell 3 v zero-list))
(define list (make-cell 3 (make-cell 3 zero one) zero-v-list))
(define zero-v-list (core:make-cell 3 v zero-list))
(define list (core:make-cell 3 (make-cell 3 zero one) zero-v-list))
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(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
;;; 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)
(define two (make-cell 2 0 2))
(define pair2-nil (make-cell 3 two '()))
(define two (core:make-cell 2 0 2))
(define pair2-nil (core:make-cell 3 two '()))
(display "\npair2-nil=") (display pair2-nil) (newline)
(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)
(gc-show)
(define three (make-cell 2 0 3))
(define four (make-cell 2 0 4))
(define pair4-nil (make-cell 3 four '()))
(define list3-4 (make-cell 3 three pair4-nil))
(define list1234 (make-cell 3 list1-2 list3-4))
(define three (core:make-cell 2 0 3))
(define four (core:make-cell 2 0 4))
(define pair4-nil (core:make-cell 3 four '()))
(define list3-4 (core:make-cell 3 three pair4-nil))
(define list1234 (core:make-cell 3 list1-2 list3-4))
(gc-show)
(gc list1234)
(gc-show)

4
tests/gc.test
View file

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

2
vector.c
View file

@ -24,7 +24,7 @@ make_vector (SCM n)
int k = VALUE (n);
g_cells[tmp_num].value = TVECTOR;
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)];
return x;
}