Commit e83301e6 authored by Juergen Nickelsen's avatar Juergen Nickelsen
Browse files

more gc protect work

parent 437d907a
......@@ -706,17 +706,17 @@ obp_t bf_let(obp_t args, obp_t out_port, int level)
obp_t bf_letrec(obp_t args, obp_t out_port, int level)
{
PROTECT;
obp_t bindings = CAR(args);
obp_t body = CDR(args);
obp_t retval = 0;
int nargs = 0;
obp_t symbols = the_Nil;
PROTECT; protect(symbols);
OBVAR(retval);
OBVAR(symbols);
OBVAR(sym);
OBVAR(newvalue);
while (IS(bindings, PAIR)) {
obp_t binding = CAR(bindings);
obp_t sym;
obp_t newvalue;
if (IS(binding, SYMBOL)) {
sym = binding;
newvalue = the_Nil;
......@@ -725,25 +725,18 @@ obp_t bf_letrec(obp_t args, obp_t out_port, int level)
sym = CAR(binding);
if (!IS(sym, SYMBOL)) {
retval = throw_error(out_port, ERR_LETARGS,
sym, "not a symbol");
goto RESTORE_BINDINGS;
ERROR(out_port, ERR_LETARGS,
sym, "not a symbol");
}
if (!IS(rest, PAIR) || !IS_NIL(CDR(rest))) {
retval = throw_error(out_port, ERR_LETARGS,
binding,
"malformed binding");
goto RESTORE_BINDINGS;
ERROR(out_port, ERR_LETARGS, binding,
"malformed binding");
}
newvalue = eval(CAR(rest), out_port, level);
if (IS_EXIT(newvalue)) {
retval = newvalue;
goto RESTORE_BINDINGS;
}
CHECK_ERROR(newvalue);
} else {
retval = throw_error(out_port, ERR_LETARGS, binding,
"not symbol or list");
goto RESTORE_BINDINGS;
ERROR(out_port, ERR_LETARGS, binding,
"not symbol or list");
}
Lsymbol_t *symbol = AS(sym, SYMBOL);
pushdown(symbol->value);
......@@ -755,13 +748,11 @@ obp_t bf_letrec(obp_t args, obp_t out_port, int level)
while (IS(body, PAIR)) {
retval = eval(CAR(body), out_port, level);
if (IS_EXIT(retval)) {
break;
}
CHECK_ERROR(retval);
body = CDR(body);
}
RESTORE_BINDINGS:
EXIT:
restore_bindings(symbols, nargs, out_port, level);
UNPROT;
return retval;
......@@ -775,93 +766,111 @@ obp_t bf_listp(obp_t args, obp_t out_port, int level)
obp_t bf_and(obp_t args, obp_t out_port, int level)
{
und hier auch noch
obp_t value = the_T;
PROTECT;
OBVAL(retval, the_T);
while (!IS_NIL(args)) {
obp_t cond = CAR(args);
obp_t value = eval(cond, out_port, level);
CHECK_ERROR(value);
if (IS_NIL(value)) {
retval = eval(cond, out_port, level);
CHECK_ERROR(retval);
if (IS_NIL(retval)) {
break;
}
}
return value;
EXIT:
UNPROT;
return retval;
}
obp_t bf_or(obp_t args, obp_t out_port, int level)
{
obp_t value = the_Nil;
PROTECT;
OBVAR(retval);
while (!IS_NIL(args)) {
obp_t cond = CAR(args);
obp_t value = eval(cond, out_port, level);
CHECK_ERROR(value);
if (!IS_NIL(value)) {
retval = eval(cond, out_port, level);
CHECK_ERROR(retval);
if (!IS_NIL(retval)) {
break;
}
}
return value;
EXIT:
UNPROT;
return retval;
}
obp_t bf_progn(obp_t args, obp_t out_port, int level)
{
obp_t value = the_Nil;
PROTECT;
OBVAR(retval);
while (!IS_NIL(args)) {
obp_t arg = CAR(args);
value = eval(arg, out_port, level);
CHECK_ERROR(value);
retval = eval(arg, out_port, level);
CHECK_ERROR(retval);
args = CDR(args);
}
return value;
EXIT:
UNPROT;
return retval;
}
obp_t bf_prog1(obp_t args, obp_t out_port, int level)
{
PROTECT;
obp_t first = CAR(args);
obp_t retval = eval(first, out_port, level);
OBVAL(retval, eval(first, out_port, level));
CHECK_ERROR(retval);
args = CDR(args);
while (!IS_NIL(args)) {
obp_t value = eval(CAR(args), out_port, level);
CHECK_ERROR(value);
retval = eval(CAR(args), out_port, level);
CHECK_ERROR(retval);
args = CDR(args);
}
EXIT:
UNPROT;
return retval;
}
obp_t bf_prog2(obp_t args, obp_t out_port, int level)
{
PROTECT;
OBVAR(retval);
obp_t first = CAR(args);
obp_t value = eval(first, out_port, level);
CHECK_ERROR(value);
OBVAL(val, eval(first, out_port, level));
CHECK_ERROR(retval);
args = CDR(args);
obp_t second = CAR(args);
obp_t retval = eval(second, out_port, level);
retval = eval(second, out_port, level);
CHECK_ERROR(retval);
args = CDR(args);
while (!IS_NIL(args)) {
value = eval(CAR(args), out_port, level);
CHECK_ERROR(value);
val = eval(CAR(args), out_port, level);
CHECK_ERROR(val);
args = CDR(args);
}
EXIT:
UNPROT;
return retval;
}
obp_t bf_while(obp_t args, obp_t out_port, int level)
{
PROTECT;
OBVAR(cond);
OBVAR(retval);
obp_t test = CAR(args);
obp_t body = CDR(args);
do {
obp_t cond = eval(test, out_port, level);
cond = eval(test, out_port, level);
CHECK_ERROR(cond);
if (IS_NIL(cond)) {
return the_Nil;
break;
}
obp_t forms = body;
while (!IS_NIL(forms)) {
......@@ -869,7 +878,9 @@ obp_t bf_while(obp_t args, obp_t out_port, int level)
forms = CDR(forms);
}
} while (1);
return the_Nil;
EXIT:
UNPROT;
return retval;
}
obp_t bf_unwind_protect(obp_t args, obp_t out_port, int level)
......@@ -877,12 +888,12 @@ obp_t bf_unwind_protect(obp_t args, obp_t out_port, int level)
obp_t form = CAR(args);
obp_t cleanupforms = CDR(args);
obp_t value = eval(form, out_port, level);
obp_t retval = eval(form, out_port, level);
while (!IS_NIL(cleanupforms)) {
eval(CAR(cleanupforms), out_port, level);
cleanupforms = CDR(cleanupforms);
}
return value; /* which may be a error */
return retval; /* which may be a error */
}
obp_t bf_princs(obp_t args, obp_t out_port, int level)
......@@ -900,52 +911,54 @@ obp_t bf_prin1s(obp_t args, obp_t out_port, int level)
obp_t bf_prin1(obp_t args, obp_t out_port, int level)
{
obp_t expr = CAR(args);
obp_t out = out_port;
args = CDR(args);
if (!IS_NIL(args)) {
out = CAR(args);
if (IS_NIL(out)) {
out = the_Stdout;
out_port = CAR(args);
if (IS_NIL(out_port)) {
out_port = the_Stdout;
}
}
obp_t s = prin1_string(expr);
port_write(out, THE_STRINGS(s));
port_write(out_port, THE_STRINGS(s));
return s;
}
obp_t bf_princ(obp_t args, obp_t out_port, int level)
{
obp_t expr = CAR(args);
obp_t out = out_port;
args = CDR(args);
if (!IS_NIL(args)) {
out = CAR(args);
if (IS_NIL(out)) {
out = the_Stdout;
out_port = CAR(args);
if (IS_NIL(out_port)) {
out_port = the_Stdout;
}
}
obp_t s = princ_string(expr);
port_write(out, THE_STRINGS(s));
port_write(out_port, THE_STRINGS(s));
return s;
}
obp_t bf_errset(obp_t args, obp_t out_port, int level)
{
obp_t value = the_Nil;
PROTECT;
OBVAR(retval);
while (!IS_NIL(args)) {
value = eval(CAR(args), out_port, level);
if (IS_EXIT(value)) {
return the_Nil;
}
retval = eval(CAR(args), out_port, level);
CHECK_ERROR(retval);
args = CDR(args);
}
return cons(value, the_Nil);
retval = cons(retval, the_Nil);
EXIT:
UNPROT;
return retval;
}
// function filename 'special
obp_t bf_autoload(obp_t args, obp_t out_port, int level)
{
PROTECT;
OBVAR(retval);
obp_t sym = CAR(args);
args = CDR(args);
obp_t filename = CAR(args);
......@@ -954,24 +967,29 @@ obp_t bf_autoload(obp_t args, obp_t out_port, int level)
CHECKTYPE(out_port, sym, SYMBOL);
CHECKTYPE(out_port, filename, STRING);
obp_t func = new_autoload_function(THE_STRINGS(AS(sym, SYMBOL)->name),
filename, is_special != the_Nil);
OBVAL(func, new_autoload_function(THE_STRINGS(AS(sym, SYMBOL)->name),
filename, is_special != the_Nil));
AS(sym, SYMBOL)->function = func;
return func;
retval = func;
EXIT:
UNPROT;
return retval;
}
// object 'tostring
obp_t bf_describe(obp_t args, obp_t out_port, int level)
{
PROTECT;
obp_t ob = CAR(args);
strbuf_t sb = describe(ob, 0);
obp_t retval = the_T;
OBVAL(retval, the_T);
if (CDR(args) != the_Nil && CADR(args) != the_Nil) {
retval = new_string(strbuf_string(sb), strbuf_size(sb));
} else {
port_write(the_Stdout, strbuf_string(sb), strbuf_size(sb));
}
UNPROT;
free(sb);
return retval;
}
......
......@@ -290,7 +290,6 @@ obp_t evalfun(obp_t func, obp_t args, obp_t out_port, int level)
obp_t eval(obp_t ob, obp_t out_port, int level)
{
PROTECT;
protect(ob);
OBVAR(retval);
Lpair_t *pair;
......
......@@ -30,7 +30,7 @@ void gc_unprotect(gcp_t prot_state)
uint marked;
uint freed;
uint alloced;
uint swept;
uint visited;
void gc_mark(obp_t ob)
{
......@@ -50,7 +50,7 @@ obp_t sweep_runner(obp_t obs, obp_t result)
return result;
}
swept++;
visited++;
obp_t first = obs;
obp_t rest = obs->next;
......@@ -81,8 +81,8 @@ void gc(void)
marked = 0;
freed = 0;
alloced = 0;
swept = 0;
fprintf(stderr, "\n[GC.");
visited = 0;
fprintf(stderr, "[GC.");
traverse_ob((obp_t) gc_prot_root, gc_mark, gc_stop_traverse);
fprintf(stderr, ".");
traverse_ob((obp_t) pushdown_list, gc_mark, gc_stop_traverse);
......@@ -90,8 +90,8 @@ void gc(void)
traverse_ob(symbols, gc_mark, gc_stop_traverse);
fprintf(stderr, ".");
gc_sweep();
fprintf(stderr, " %u marked, %u freed, %u alloced, %u swept]",
marked, freed, alloced, swept);
fprintf(stderr, " %u marked, %u freed, %u alloced, %u visited]\n",
marked, freed, alloced, visited);
}
......
......@@ -11,6 +11,7 @@ void gc_unprotect(gcp_t prot_state);
#define PROTECT gcp_t gc_prot_state = gc_start_protect()
#define UNPROT gc_unprotect(gc_prot_state)
#define OBVAR(var) obp_t var = the_Nil; gc_protect(&var)
#define OBVAL(var, val) obp_t var = val; gc_protect(&var)
void gc();
......
......@@ -39,14 +39,17 @@ char *port_type_name(port_type_t type)
obp_t make_stream_port(char *fname, char *fmode)
{
FILE *stream = fopen(fname, fmode);
OBVAR(retval);
if (stream == 0) {
ERROR(the_Stderr, ERR_SYSTEM, 0, "error opening %s: %s",
fname, strerror(errno));
}
int in = fmode[0] == 'r' || fmode[1] == '+';
int out = strchr("wa", fmode[0]) || fmode[1] == '+';
return new_port(new_zstring(fname), stream, -1, 0,
STREAM_PORT, in, out);
retval = new_port(new_zstring(fname), stream, -1, 0,
STREAM_PORT, in, out);
EXIT:
return retval;
}
obp_t make_string_port(char *name)
......@@ -102,6 +105,7 @@ obp_t port_putc(obp_t port, char c)
obp_t port_write(obp_t port, char *s, uint len)
{
Lport_t *p = AS(port, PORT);
OBVAR(retval);
if (p->closed) {
ERROR(the_Stderr, ERR_CLPORT, port, "port is closed");
......@@ -129,21 +133,25 @@ obp_t port_write(obp_t port, char *s, uint len)
ERROR(the_Stderr, ERR_INVARG, port,
"invalid type %d of port", p->type);
}
return port;
retval = port;
EXIT:
return retval;
}
obp_t port_vprintf(obp_t port, char *format, va_list arglist)
{
char *string ;
OBVAR(retval);
int vasprintf_ret = vasprintf(&string, format, arglist);
if (vasprintf_ret < 0) {
ERROR(the_Stderr, ERR_MEMORY, 0, "vasprintf() failed");
}
obp_t result = port_print(port, string);
retval = port_print(port, string);
free(string);
return result;
EXIT:
return retval;
}
obp_t port_printf(obp_t port, char *format, ...)
......@@ -165,7 +173,8 @@ obp_t get_port_string(obp_t port)
return new_string(strbuf_string(p->port.strbuf),
strbuf_size(p->port.strbuf));
} else {
ERROR(the_Stderr, ERR_INVARG, port, "port is not a string buffer");
return throw_error(the_Stderr, ERR_INVARG, port,
"port is not a string buffer");
}
}
......@@ -204,6 +213,7 @@ obp_t port_read(obp_t port, uint len)
Lport_t *p = AS(port, PORT);
char *read_buf;
int read_ret;
OBVAR(retval);
if (p->closed) {
ERROR(the_Stderr, ERR_CLPORT, port, "port is closed");
......@@ -235,13 +245,15 @@ obp_t port_read(obp_t port, uint len)
ERROR(the_Stderr, ERR_INVARG, port,
"invalid type %d of port", p->type);
}
obp_t result = new_string(read_buf, read_ret);
retval = new_string(read_buf, read_ret);
EXIT:
free(read_buf);
return result;
return retval;
}
obp_t close_port(obp_t port)
{
OBVAR(retval);
if (!IS(port, PORT)) {
ERROR(the_Stderr, ERR_INVARG, port, "port argument needed");
}
......@@ -271,17 +283,23 @@ obp_t close_port(obp_t port)
ERROR(the_Stderr, ERR_INVARG, port,
"invalid type %d of close port", p->type);
}
return port;
retval = port;
EXIT:
return retval;
}
obp_t load_file(char *fname, obp_t out_port, int level)
{
obp_t port = make_stream_port(fname, "r");
PROTECT;
OBVAR(retval);
OBVAL(port, make_stream_port(fname, "r"));
CHECK_ERROR(port);
obp_t value = repl(port, out_port, 0, level);
retval = repl(port, out_port, 0, level);
close_port(port);
return value;
EXIT:
UNPROT;
return retval;
}
void init_io(void)
......
......@@ -45,7 +45,7 @@ obp_t popup(void)
gcp_t entry = pushdown_list;
pushdown_list = pushdown_list->next;
obp_t value = entry->item.value;
ob_free((obp_t) entry);
//ob_free((obp_t) entry);
return value;
}
......@@ -69,7 +69,7 @@ obp_t new_object(uint size, int type)
{
obp_t ob = 0; /* the object to be */
if (object_count % GC_OBJ_COUNT == 0 && type != GCPROT) {
if (object_count && object_count % GC_OBJ_COUNT == 0 && type != GCPROT) {
gc();
}
......
......@@ -241,7 +241,7 @@ void traverse_gcprot(obp_t ob, void (*do_func)(obp_t), int (*stop_func)(obp_t))
void traverse_ob(obp_t ob, void (*do_func)(obp_t), int (*stop_func)(obp_t))
{
if (stop_func(ob)) {
if (!ob || stop_func(ob)) {
return;
}
do_func(ob);
......
......@@ -5,22 +5,29 @@
#include "printer.h"
#include "eval.h"
#include "signals.h"
#include "gc.h"
#define PROMPT "> "
obp_t repl(obp_t in, obp_t out, int interactive, int level)
{
obp_t value = the_Nil;
PROTECT;
OBVAR(value);
OBVAR(expr);
obp_t name = AS(in, PORT)->name;
reader_t reader =
new_reader(AS(name, STRING)->content, in, out);
while (1) {
if (interactive) {
port_printf(out,
"%ld obs %ld evals %ld applys %ld bindings\n",
object_count, eval_count, apply_count,
bind_count);
port_print(out, PROMPT);
port_flush(out);
}
obp_t expr = read_expr(reader);
expr = read_expr(reader);
if (traceflag) {
port_print(out, "read expression: ");
print_expr(expr, out);
......@@ -45,6 +52,7 @@ obp_t repl(obp_t in, obp_t out, int interactive, int level)
terpri(out);
}
free_reader(reader);
UNPROT;
return value;
}
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment