Commit 76a2088a authored by Juergen Nickelsen's avatar Juergen Nickelsen
Browse files

more work on the gc, largely successful (traversing symbols is quite

rewarding); builtins now get the number of arguments passed, which
we have anyway; trace-function and the related bit; port name is
no longer a Lisp string (no reason why it should be); s_expr now
exported from the printer
parent f1ed8b6e
......@@ -2,6 +2,9 @@
*: to do; +: done; -: rejected; @: in progress
* a more useful tracing facility (eval, bindings, gc, gctraverse,
gcprotect, objects (new), ...)
* reentrant hashmap enumeration
* replace the out_port passed through everywhere by a more general
......@@ -23,6 +26,8 @@
* flet
+ trace bit with functions
+ autoload
+ perhaps lambda (and mu) could be a special form that verifies a
......
......@@ -38,10 +38,10 @@ obp_t call_builtin(obp_t fun, obp_t args, obp_t out_port, int level)
"invalid number of arguments, %d not in [%d..%d]",
nargs, bi->minargs, bi->maxargs);
}
return bi->impl.builtin(args, out_port, level);
return bi->impl.builtin(nargs, args, out_port, level);
}
obp_t bf_length(obp_t args, obp_t out_port, int level)
obp_t bf_length(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t ob = CAR(args);
long value;
......@@ -72,13 +72,13 @@ obp_t bf_length(obp_t args, obp_t out_port, int level)
return new_integer(value);
}
obp_t bf_setq(obp_t args, obp_t out_port, int level)
obp_t bf_setq(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
PROTVAR(retval);
PROTVAR(symbol);
if (list_length(args) % 2 != 0) {
if (nargs % 2 != 0) {
ERROR(out_port, ERR_NOARGS, args,
"uneven number of args to setq");
}
......@@ -100,13 +100,13 @@ obp_t bf_setq(obp_t args, obp_t out_port, int level)
return retval;
}
obp_t bf_lambda(obp_t args, obp_t out_port, int level)
obp_t bf_lambda(int nargs, obp_t args, obp_t out_port, int level)
{
return make_function(0, 0, new_pair(the_Lambda, args), out_port);
}
obp_t bf_if(obp_t args, obp_t out_port, int level)
obp_t bf_if(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
PROTVAR(retval);
......@@ -135,7 +135,7 @@ obp_t bf_if(obp_t args, obp_t out_port, int level)
return retval;
}
obp_t bf_car(obp_t args, obp_t out_port, int level)
obp_t bf_car(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t arg = CAR(args);
if (IS(arg, PAIR)) {
......@@ -147,7 +147,7 @@ obp_t bf_car(obp_t args, obp_t out_port, int level)
}
}
obp_t bf_cdr(obp_t args, obp_t out_port, int level)
obp_t bf_cdr(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t arg = CAR(args);
if (IS(arg, PAIR)) {
......@@ -159,24 +159,24 @@ obp_t bf_cdr(obp_t args, obp_t out_port, int level)
}
}
obp_t bf_cons(obp_t args, obp_t out_port, int level)
obp_t bf_cons(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t arg1 = CAR(args);
obp_t arg2 = CADR(args);
return new_pair(arg1, arg2);
}
obp_t bf_eval(obp_t args, obp_t out_port, int level)
obp_t bf_eval(int nargs, obp_t args, obp_t out_port, int level)
{
return eval(CAR(args), out_port, level);
}
obp_t bf_quote(obp_t args, obp_t out_port, int level)
obp_t bf_quote(int nargs, obp_t args, obp_t out_port, int level)
{
return CAR(args);
}
obp_t bf_load(obp_t args, obp_t out_port, int level)
obp_t bf_load(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
PROTVAR(retval);
......@@ -197,26 +197,26 @@ obp_t bf_load(obp_t args, obp_t out_port, int level)
return retval;;
}
obp_t bf_symbol_name(obp_t args, obp_t out_port, int level)
obp_t bf_symbol_name(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t sym = CAR(args);
CHECKTYPE_RET(out_port, sym, SYMBOL);
return AS(sym, SYMBOL)->name;
}
obp_t bf_symbol_function(obp_t args, obp_t out_port, int level)
obp_t bf_symbol_function(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t sym = CAR(args);
CHECKTYPE_RET(out_port, sym, SYMBOL);
return AS(sym, SYMBOL)->function;
}
obp_t bf_symbols(obp_t args, obp_t out_port, int level)
obp_t bf_symbols(int nargs, obp_t args, obp_t out_port, int level)
{
return all_symbols();
}
obp_t bf_fset(obp_t args, obp_t out_port, int level)
obp_t bf_fset(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
PROTVAR(retval);
......@@ -255,22 +255,22 @@ obp_t def_common(obp_t args, obp_t out_port, obp_t marker)
return retval;
}
obp_t bf_defun(obp_t args, obp_t out_port, int level)
obp_t bf_defun(int nargs, obp_t args, obp_t out_port, int level)
{
return def_common(args, out_port, the_Lambda);
}
obp_t bf_defspecial(obp_t args, obp_t out_port, int level)
obp_t bf_defspecial(int nargs, obp_t args, obp_t out_port, int level)
{
return def_common(args, out_port, the_Mu);
}
obp_t bf_eq(obp_t args, obp_t out_port, int level)
obp_t bf_eq(int nargs, obp_t args, obp_t out_port, int level)
{
return CAR(args) == CADR(args) ? the_T : the_Nil;
}
obp_t bf_eql(obp_t args, obp_t out_port, int level)
obp_t bf_eql(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t arg1 = CAR(args);
obp_t arg2 = CADR(args);
......@@ -287,7 +287,7 @@ obp_t bf_eql(obp_t args, obp_t out_port, int level)
}
}
obp_t bf_plus(obp_t args, obp_t out_port, int level)
obp_t bf_plus(int nargs, obp_t args, obp_t out_port, int level)
{
long value = 0;
while (!IS_NIL(args)) {
......@@ -299,7 +299,7 @@ obp_t bf_plus(obp_t args, obp_t out_port, int level)
return new_integer(value);
}
obp_t bf_minus(obp_t args, obp_t out_port, int level)
obp_t bf_minus(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t first = CAR(args);
CHECKTYPE_RET(out_port, first, NUMBER);
......@@ -315,7 +315,7 @@ obp_t bf_minus(obp_t args, obp_t out_port, int level)
return new_integer(value);
}
obp_t bf_times(obp_t args, obp_t out_port, int level)
obp_t bf_times(int nargs, obp_t args, obp_t out_port, int level)
{
long value = 1;
while (!IS_NIL(args)) {
......@@ -327,7 +327,7 @@ obp_t bf_times(obp_t args, obp_t out_port, int level)
return new_integer(value);
}
obp_t bf_divide(obp_t args, obp_t out_port, int level)
obp_t bf_divide(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t start = CAR(args);
CHECKTYPE_RET(out_port, start, NUMBER);
......@@ -343,7 +343,7 @@ obp_t bf_divide(obp_t args, obp_t out_port, int level)
return new_integer(value);
}
obp_t bf_modulo(obp_t args, obp_t out_port, int level)
obp_t bf_modulo(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t start = CAR(args);
CHECKTYPE_RET(out_port, start, NUMBER);
......@@ -359,7 +359,7 @@ obp_t bf_modulo(obp_t args, obp_t out_port, int level)
return new_integer(value);
}
obp_t bf_equals(obp_t args, obp_t out_port, int level)
obp_t bf_equals(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t start = CAR(args);
CHECKTYPE_RET(out_port, start, NUMBER);
......@@ -377,7 +377,7 @@ obp_t bf_equals(obp_t args, obp_t out_port, int level)
return the_T;
}
obp_t bf_greater(obp_t args, obp_t out_port, int level)
obp_t bf_greater(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t start = CAR(args);
CHECKTYPE_RET(out_port, start, NUMBER);
......@@ -398,7 +398,7 @@ obp_t bf_greater(obp_t args, obp_t out_port, int level)
return the_T;
}
obp_t bf_greatere(obp_t args, obp_t out_port, int level)
obp_t bf_greatere(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t start = CAR(args);
CHECKTYPE_RET(out_port, start, NUMBER);
......@@ -418,7 +418,7 @@ obp_t bf_greatere(obp_t args, obp_t out_port, int level)
return the_T;
}
obp_t bf_less(obp_t args, obp_t out_port, int level)
obp_t bf_less(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t start = CAR(args);
CHECKTYPE_RET(out_port, start, NUMBER);
......@@ -438,7 +438,7 @@ obp_t bf_less(obp_t args, obp_t out_port, int level)
return the_T;
}
obp_t bf_lesse(obp_t args, obp_t out_port, int level)
obp_t bf_lesse(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t start = CAR(args);
CHECKTYPE_RET(out_port, start, NUMBER);
......@@ -458,20 +458,20 @@ obp_t bf_lesse(obp_t args, obp_t out_port, int level)
return the_T;
}
obp_t bf_zerop(obp_t args, obp_t out_port, int level)
obp_t bf_zerop(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t arg = CAR(args);
CHECKTYPE_RET(out_port, arg, NUMBER);
return (AS(arg, NUMBER)->value == 0 ? the_T : the_Nil);
}
obp_t bf_null(obp_t args, obp_t out_port, int level)
obp_t bf_null(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t arg = CAR(args);
return (arg == the_Nil ? the_T : the_Nil);
}
obp_t bf_trace(obp_t args, obp_t out_port, int level)
obp_t bf_trace(int nargs, obp_t args, obp_t out_port, int level)
{
if (args != the_Nil) {
traceflag = CAR(args) == the_Nil ? 0 : 1;
......@@ -479,7 +479,7 @@ obp_t bf_trace(obp_t args, obp_t out_port, int level)
return traceflag ? the_T : the_Nil;
}
obp_t bf_tty(obp_t args, obp_t out_port, int level)
obp_t bf_tty(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t port = the_Stdin;
if (args != the_Nil) {
......@@ -493,14 +493,14 @@ obp_t bf_tty(obp_t args, obp_t out_port, int level)
return port_tty(port);
}
obp_t bf_atom(obp_t args, obp_t out_port, int level)
obp_t bf_atom(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t arg = CAR(args);
return IS(arg, PAIR) ? the_Nil : the_T;
}
obp_t bf_function(obp_t args, obp_t out_port, int level)
obp_t bf_function(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t arg = CAR(args);
switch (arg->type) {
......@@ -515,7 +515,7 @@ obp_t bf_function(obp_t args, obp_t out_port, int level)
}
}
obp_t bf_cond(obp_t args, obp_t out_port, int level)
obp_t bf_cond(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
PROTVAR(antecedent);
......@@ -537,7 +537,7 @@ obp_t bf_cond(obp_t args, obp_t out_port, int level)
return retval;
}
obp_t bf_time(obp_t args, obp_t out_port, int level)
obp_t bf_time(int nargs, obp_t args, obp_t out_port, int level)
{
struct timeval from;
struct timeval to;
......@@ -554,7 +554,7 @@ obp_t bf_time(obp_t args, obp_t out_port, int level)
struct timeval start_time;
obp_t bf_measure(obp_t args, obp_t out_port, int level)
obp_t bf_measure(int nargs, obp_t args, obp_t out_port, int level)
{
struct timeval from;
struct timeval to;
......@@ -605,7 +605,7 @@ obp_t bf_measure(obp_t args, obp_t out_port, int level)
return result;
}
obp_t bf_apropos(obp_t args, obp_t out_port, int level)
obp_t bf_apropos(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t pattern = princ_string(CAR(args));
Lstring_t *search = AS(pattern, STRING);
......@@ -623,7 +623,7 @@ obp_t bf_apropos(obp_t args, obp_t out_port, int level)
return result;
}
obp_t bf_funcall(obp_t args, obp_t out_port, int level)
obp_t bf_funcall(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t fun = CAR(args);
CHECKTYPE_RET(out_port, fun, FUNCTION);
......@@ -631,7 +631,7 @@ obp_t bf_funcall(obp_t args, obp_t out_port, int level)
return apply(fun, arglist, out_port, level);
}
obp_t bf_apply(obp_t args, obp_t out_port, int level)
obp_t bf_apply(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t fun = CAR(args);
CHECKTYPE_RET(out_port, fun, FUNCTION);
......@@ -643,12 +643,12 @@ obp_t bf_apply(obp_t args, obp_t out_port, int level)
return apply(fun, arglist, out_port, level);
}
obp_t bf_list(obp_t args, obp_t out_port, int level)
obp_t bf_list(int nargs, obp_t args, obp_t out_port, int level)
{
return args;
}
obp_t bf_let(obp_t args, obp_t out_port, int level)
obp_t bf_let(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
obp_t bindings = CAR(args);
......@@ -656,7 +656,7 @@ obp_t bf_let(obp_t args, obp_t out_port, int level)
PROTVAR(retval);
PROTVAR(symbols);
PROTVAR(values);
PROTVAR(nargs);
PROTVAR(nbindings);
PROTVAR(sym);
PROTVAR(value);
......@@ -690,8 +690,8 @@ obp_t bf_let(obp_t args, obp_t out_port, int level)
ERROR(out_port, ERR_LETARGS, CAR(args),
"bindings not a proper list");
}
nargs = make_bindings(symbols, values, out_port, level);
CHECK_ERROR(nargs);
nbindings = make_bindings(symbols, values, out_port, level);
CHECK_ERROR(nbindings);
while (IS(body, PAIR)) {
retval = eval(CAR(body), out_port, level);
......@@ -699,17 +699,17 @@ obp_t bf_let(obp_t args, obp_t out_port, int level)
body = CDR(body);
}
EXIT:
restore_bindings(symbols, AS(nargs, NUMBER)->value, out_port, level);
restore_bindings(symbols, AS(nbindings, NUMBER)->value, out_port, level);
UNPROTECT;
return retval;
}
obp_t bf_letrec(obp_t args, obp_t out_port, int level)
obp_t bf_letrec(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
obp_t bindings = CAR(args);
int nbindings = 0;
obp_t body = CDR(args);
int nargs = 0;
PROTVAR(retval);
PROTVAR(symbols);
PROTVAR(sym);
......@@ -741,7 +741,7 @@ obp_t bf_letrec(obp_t args, obp_t out_port, int level)
Lsymbol_t *symbol = AS(sym, SYMBOL);
pushdown(symbol->value);
symbols = cons(sym, symbols);
nargs++;
nbindings++;
symbol->value = newvalue;
bindings = CDR(bindings);
}
......@@ -753,18 +753,18 @@ obp_t bf_letrec(obp_t args, obp_t out_port, int level)
}
EXIT:
restore_bindings(symbols, nargs, out_port, level);
restore_bindings(symbols, nbindings, out_port, level);
UNPROTECT;
return retval;
}
obp_t bf_listp(obp_t args, obp_t out_port, int level)
obp_t bf_listp(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t arg = CAR(args);
return IS_LIST(arg) ? the_T : the_Nil;
}
obp_t bf_and(obp_t args, obp_t out_port, int level)
obp_t bf_and(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
PROTVAL(retval, the_T);
......@@ -781,7 +781,7 @@ obp_t bf_and(obp_t args, obp_t out_port, int level)
return retval;
}
obp_t bf_or(obp_t args, obp_t out_port, int level)
obp_t bf_or(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
PROTVAR(retval);
......@@ -798,7 +798,7 @@ obp_t bf_or(obp_t args, obp_t out_port, int level)
return retval;
}
obp_t bf_progn(obp_t args, obp_t out_port, int level)
obp_t bf_progn(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
PROTVAR(retval);
......@@ -814,7 +814,7 @@ obp_t bf_progn(obp_t args, obp_t out_port, int level)
}
obp_t bf_prog1(obp_t args, obp_t out_port, int level)
obp_t bf_prog1(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
obp_t first = CAR(args);
......@@ -833,7 +833,7 @@ obp_t bf_prog1(obp_t args, obp_t out_port, int level)
}
obp_t bf_prog2(obp_t args, obp_t out_port, int level)
obp_t bf_prog2(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
PROTVAR(retval);
......@@ -858,7 +858,7 @@ obp_t bf_prog2(obp_t args, obp_t out_port, int level)
}
obp_t bf_while(obp_t args, obp_t out_port, int level)
obp_t bf_while(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
PROTVAR(cond);
......@@ -883,7 +883,7 @@ obp_t bf_while(obp_t args, obp_t out_port, int level)
return retval;
}
obp_t bf_unwind_protect(obp_t args, obp_t out_port, int level)
obp_t bf_unwind_protect(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t form = CAR(args);
obp_t cleanupforms = CDR(args);
......@@ -898,19 +898,19 @@ obp_t bf_unwind_protect(obp_t args, obp_t out_port, int level)
return retval; /* which may be a error */
}
obp_t bf_princs(obp_t args, obp_t out_port, int level)
obp_t bf_princs(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t expr = CAR(args);
return princ_string(expr);
}
obp_t bf_prin1s(obp_t args, obp_t out_port, int level)
obp_t bf_prin1s(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t expr = CAR(args);
return prin1_string(expr);
}
obp_t bf_prin1(obp_t args, obp_t out_port, int level)
obp_t bf_prin1(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t expr = CAR(args);
args = CDR(args);
......@@ -925,7 +925,7 @@ obp_t bf_prin1(obp_t args, obp_t out_port, int level)
return s;
}
obp_t bf_princ(obp_t args, obp_t out_port, int level)
obp_t bf_princ(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t expr = CAR(args);
args = CDR(args);
......@@ -940,7 +940,7 @@ obp_t bf_princ(obp_t args, obp_t out_port, int level)
return s;
}
obp_t bf_errset(obp_t args, obp_t out_port, int level)
obp_t bf_errset(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
PROTVAR(retval);
......@@ -957,7 +957,7 @@ obp_t bf_errset(obp_t args, obp_t out_port, int level)
}
// function filename 'special
obp_t bf_autoload(obp_t args, obp_t out_port, int level)
obp_t bf_autoload(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
PROTVAR(retval);
......@@ -979,7 +979,7 @@ obp_t bf_autoload(obp_t args, obp_t out_port, int level)
}
// object 'tostring
obp_t bf_describe(obp_t args, obp_t out_port, int level)
obp_t bf_describe(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
obp_t ob = CAR(args);
......@@ -997,12 +997,23 @@ obp_t bf_describe(obp_t args, obp_t out_port, int level)
}
obp_t bf_gc(obp_t args, obp_t out_port, int level)
obp_t bf_gc(int nargs, obp_t args, obp_t out_port, int level)
{
gc();
return the_Nil;
}
obp_t bf_trace_function(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t arg1 = CAR(args);
Lfunction_t *func = AS(arg1, FUNCTION);
if (nargs == 2) {
func->trace = CADR(args) == the_Nil ? 0 : 1;
}
return func->trace ? the_T : the_Nil;
}
Lfunction_t *new_function_common(char *name, uint namelen, int is_special,
short minargs, short maxargs)
......@@ -1050,12 +1061,14 @@ obp_t new_builtin_function(char *name, uint namelen, builtin_func_t builtin,
obp_t register_builtin(char *name, builtin_func_t builtin,
int is_special, short minargs, short maxargs)
{
obp_t bi = new_builtin_function(name, strlen(name) + 1, builtin,
is_special, minargs, maxargs);
PROTECT;
PROTVAL(bi, new_builtin_function(name, strlen(name), builtin,
is_special, minargs, maxargs));
Lsymbol_t *sym = AS(get_symbol_z(name), SYMBOL);
//describe((obp_t) sym);
sym->function = bi;
//describe((obp_t) sym);
UNPROTECT;
return bi;
}
......@@ -1120,6 +1133,7 @@ void init_builtins(void)
register_builtin(LENGTH_NAME, bf_length, 0, 1, 1);
register_builtin(APROPOS_NAME, bf_apropos, 0, 1, 1);
register_builtin(GC_NAME, bf_gc, 0, 0, 0);
register_builtin(TRACE_FUNCTION_NAME, bf_trace_function, 0, 1, 2);
gettimeofday(&start_time, 0);
}
......
......@@ -8,7 +8,7 @@
#ifndef __BUILTINS_H_INC
#define __BUILTINS_H_INC
typedef obp_t builtin_func_t(obp_t args, obp_t out_port, int level);
typedef obp_t builtin_func_t(int nargs, obp_t args, obp_t out_port, int level);
obp_t call_builtin(obp_t fun, obp_t args, obp_t out_port, int level);
void init_builtins(void);
......
#include "cbasics.h"
#include <stdlib.h>
#include "objects.h"
#include "eval.h"
#include "signals.h"
......@@ -280,6 +282,18 @@ obp_t evalfun(obp_t func, obp_t args, obp_t out_port, int level)
}
args = ev_args;
}
if (AS(func, FUNCTION)->trace) {
strbuf_t sb = strbuf_new();
sb = s_expr(func, sb, 0);
port_printf(out_port, "%s(%s", blanks(level), strbuf_string(sb));
for (obp_t elem = ev_args; IS(elem, PAIR); elem = CDR(elem)) {
strbuf_reinit(sb);
sb = s_expr(elem, sb, 0);
port_printf(out_port, " %s", strbuf_string(sb));
}
port_printf(out_port, ")\n");
free(sb);
}
retval = apply(func, args, out_port, level);
EXIT:
UNPROTECT;
......
......@@ -8,14 +8,19 @@
gcp_t gc_prot_root;