27 |
Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn\n\ |
Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn\n\ |
28 |
Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\ |
Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\ |
29 |
This is free software, and you are welcome to redistribute it\n\ |
This is free software, and you are welcome to redistribute it\n\ |
30 |
under certain conditions; type 'copying;' for details.\n"; |
under certain conditions; type 'copying;' for details."; |
31 |
|
|
32 |
|
|
33 |
/* Initialize a newly created environment */ |
/* Initialize a newly created environment */ |
66 |
case 3: |
case 3: |
67 |
in_string= "Unbound Variable"; |
in_string= "Unbound Variable"; |
68 |
break; |
break; |
69 |
|
case 5: |
70 |
|
return perror(env->errsymb); |
71 |
default: |
default: |
72 |
in_string= "Unknown error"; |
in_string= "Unknown error"; |
73 |
break; |
break; |
132 |
} |
} |
133 |
|
|
134 |
|
|
|
/* Mark values recursively. |
|
|
Marked values are not collected by the GC. */ |
|
|
inline void gc_mark(value *val) |
|
|
{ |
|
|
if(val==NULL || val->gc.flag.mark) |
|
|
return; |
|
|
|
|
|
val->gc.flag.mark= 1; |
|
|
|
|
|
if(val->type==tcons) { |
|
|
gc_mark(CAR(val)); |
|
|
gc_mark(CDR(val)); |
|
|
} |
|
|
} |
|
|
|
|
|
|
|
|
/* Start GC */ |
|
|
extern void gc_init(environment *env) |
|
|
{ |
|
|
stackitem *new_head= NULL, *titem; |
|
|
symbol *tsymb; |
|
|
int i; |
|
|
|
|
|
if(env->interactive) |
|
|
printf("Garbage collecting."); |
|
|
|
|
|
/* Mark values on stack */ |
|
|
gc_mark(env->head); |
|
|
|
|
|
if(env->interactive) |
|
|
printf("."); |
|
|
|
|
|
/* Mark values in hashtable */ |
|
|
for(i= 0; i<HASHTBLSIZE; i++) |
|
|
for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next) |
|
|
if (tsymb->val != NULL) |
|
|
gc_mark(tsymb->val); |
|
|
|
|
|
if(env->interactive) |
|
|
printf("."); |
|
|
|
|
|
env->gc_count= 0; |
|
|
|
|
|
while(env->gc_ref!=NULL) { /* Sweep unused values */ |
|
|
if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */ |
|
|
|
|
|
/* Remove content */ |
|
|
switch(env->gc_ref->item->type){ |
|
|
case string: |
|
|
free(env->gc_ref->item->content.string); |
|
|
break; |
|
|
case tcons: |
|
|
free(env->gc_ref->item->content.c); |
|
|
break; |
|
|
case port: |
|
|
case empty: |
|
|
case unknown: |
|
|
case integer: |
|
|
case tfloat: |
|
|
case func: |
|
|
case symb: |
|
|
/* Symbol strings are freed when walking the hash table */ |
|
|
break; |
|
|
} |
|
|
|
|
|
free(env->gc_ref->item); /* Remove from gc_ref */ |
|
|
titem= env->gc_ref->next; |
|
|
free(env->gc_ref); /* Remove value */ |
|
|
env->gc_ref= titem; |
|
|
continue; |
|
|
} |
|
|
|
|
|
#ifdef DEBUG |
|
|
printf("Kept value (%p)", env->gc_ref->item); |
|
|
if(env->gc_ref->item->gc.flag.mark) |
|
|
printf(" (marked)"); |
|
|
if(env->gc_ref->item->gc.flag.protect) |
|
|
printf(" (protected)"); |
|
|
switch(env->gc_ref->item->type){ |
|
|
case integer: |
|
|
printf(" integer: %d", env->gc_ref->item->content.i); |
|
|
break; |
|
|
case func: |
|
|
printf(" func: %p", env->gc_ref->item->content.func); |
|
|
break; |
|
|
case symb: |
|
|
printf(" symb: %s", env->gc_ref->item->content.sym->id); |
|
|
break; |
|
|
case tcons: |
|
|
printf(" tcons: %p\t%p", CAR(env->gc_ref->item), |
|
|
CDR(env->gc_ref->item)); |
|
|
break; |
|
|
default: |
|
|
printf(" <unknown %d>", (env->gc_ref->item->type)); |
|
|
} |
|
|
printf("\n"); |
|
|
#endif /* DEBUG */ |
|
|
|
|
|
/* Keep values */ |
|
|
env->gc_count += sizeof(value); |
|
|
if(env->gc_ref->item->type==string) |
|
|
env->gc_count += strlen(env->gc_ref->item->content.string)+1; |
|
|
|
|
|
titem= env->gc_ref->next; |
|
|
env->gc_ref->next= new_head; |
|
|
new_head= env->gc_ref; |
|
|
new_head->item->gc.flag.mark= 0; |
|
|
env->gc_ref= titem; |
|
|
} |
|
|
|
|
|
if (env->gc_limit < env->gc_count*2) |
|
|
env->gc_limit= env->gc_count*2; |
|
|
|
|
|
env->gc_ref= new_head; |
|
|
|
|
|
if(env->interactive) |
|
|
printf("done (%d bytes still allocated)\n", env->gc_count); |
|
|
|
|
|
} |
|
|
|
|
|
|
|
|
inline void gc_maybe(environment *env) |
|
|
{ |
|
|
if(env->gc_count < env->gc_limit) |
|
|
return; |
|
|
else |
|
|
return gc_init(env); |
|
|
} |
|
|
|
|
|
|
|
|
/* Protect values from GC */ |
|
|
void protect(value *val) |
|
|
{ |
|
|
if(val==NULL || val->gc.flag.protect) |
|
|
return; |
|
|
|
|
|
val->gc.flag.protect= 1; |
|
|
|
|
|
if(val->type==tcons) { |
|
|
protect(CAR(val)); |
|
|
protect(CDR(val)); |
|
|
} |
|
|
} |
|
|
|
|
|
|
|
|
/* Unprotect values from GC */ |
|
|
void unprotect(value *val) |
|
|
{ |
|
|
if(val==NULL || !(val->gc.flag.protect)) |
|
|
return; |
|
|
|
|
|
val->gc.flag.protect= 0; |
|
|
|
|
|
if(val->type==tcons) { |
|
|
unprotect(CAR(val)); |
|
|
unprotect(CDR(val)); |
|
|
} |
|
|
} |
|
|
|
|
|
|
|
135 |
/* Push a value onto the stack */ |
/* Push a value onto the stack */ |
136 |
void push_val(environment *env, value *val) |
void push_val(environment *env, value *val) |
137 |
{ |
{ |
286 |
|
|
287 |
switch(val->type) { |
switch(val->type) { |
288 |
case empty: |
case empty: |
289 |
if(fprintf(stream, "[]") < 0){ |
if(fprintf(stream, "[]") < 0) |
|
perror("print_val"); |
|
290 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
291 |
break; |
break; |
292 |
case unknown: |
case unknown: |
293 |
if(fprintf(stream, "UNKNOWN") < 0){ |
if(fprintf(stream, "UNKNOWN") < 0) |
|
perror("print_val"); |
|
294 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
295 |
break; |
break; |
296 |
case integer: |
case integer: |
297 |
if(fprintf(stream, "%d", val->content.i) < 0){ |
if(fprintf(stream, "%d", val->content.i) < 0) |
|
perror("print_val"); |
|
298 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
299 |
break; |
break; |
300 |
case tfloat: |
case tfloat: |
301 |
if(fprintf(stream, "%f", val->content.f) < 0){ |
if(fprintf(stream, "%f", val->content.f) < 0) |
|
perror("print_val"); |
|
302 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
303 |
break; |
break; |
304 |
case string: |
case string: |
305 |
if(noquote){ |
if(noquote){ |
306 |
if(fprintf(stream, "%s", val->content.string) < 0){ |
if(fprintf(stream, "%s", val->content.string) < 0) |
|
perror("print_val"); |
|
307 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
308 |
} else { /* quote */ |
} else { /* quote */ |
309 |
if(fprintf(stream, "\"%s\"", val->content.string) < 0){ |
if(fprintf(stream, "\"%s\"", val->content.string) < 0) |
|
perror("print_val"); |
|
310 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
311 |
} |
} |
312 |
break; |
break; |
313 |
case symb: |
case symb: |
314 |
if(fprintf(stream, "%s", val->content.sym->id) < 0){ |
if(fprintf(stream, "%s", val->content.sym->id) < 0) |
|
perror("print_val"); |
|
315 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
316 |
break; |
break; |
317 |
case func: |
case func: |
318 |
if(fprintf(stream, "#<function %p>", val->content.func) < 0){ |
if(fprintf(stream, "#<function %p>", val->content.func) < 0) |
|
perror("print_val"); |
|
319 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
320 |
break; |
break; |
321 |
case port: |
case port: |
322 |
if(fprintf(stream, "#<port %p>", val->content.p) < 0){ |
if(fprintf(stream, "#<port %p>", val->content.p) < 0) |
|
perror("print_val"); |
|
323 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
324 |
break; |
break; |
325 |
case tcons: |
case tcons: |
326 |
if(fprintf(stream, "[ ") < 0){ |
if(fprintf(stream, "[ ") < 0) { |
|
perror("print_val"); |
|
327 |
env->err= 5; |
env->err= 5; |
328 |
return; |
return printerr(env); |
329 |
} |
} |
330 |
tstack= stack; |
tstack= stack; |
331 |
|
|
347 |
|
|
348 |
if(titem != NULL){ /* If we found it on the stack, */ |
if(titem != NULL){ /* If we found it on the stack, */ |
349 |
if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */ |
if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */ |
|
perror("print_val"); |
|
350 |
env->err= 5; |
env->err= 5; |
351 |
free(titem); |
free(titem); |
352 |
return; |
return printerr(env); |
353 |
} |
} |
354 |
} else { |
} else { |
355 |
print_val(env, CAR(val), noquote, tstack, stream); |
print_val(env, CAR(val), noquote, tstack, stream); |
371 |
} |
} |
372 |
if(titem != NULL){ /* If we found it on the stack, */ |
if(titem != NULL){ /* If we found it on the stack, */ |
373 |
if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */ |
if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */ |
|
perror("print_val"); |
|
374 |
env->err= 5; |
env->err= 5; |
375 |
|
printerr(env); |
376 |
goto printval_end; |
goto printval_end; |
377 |
} |
} |
378 |
} else { |
} else { |
379 |
if(fprintf(stream, " ") < 0){ |
if(fprintf(stream, " ") < 0){ |
|
perror("print_val"); |
|
380 |
env->err= 5; |
env->err= 5; |
381 |
|
printerr(env); |
382 |
goto printval_end; |
goto printval_end; |
383 |
} |
} |
384 |
} |
} |
385 |
break; |
break; |
386 |
default: |
default: |
387 |
if(fprintf(stream, " . ") < 0){ /* Improper list */ |
if(fprintf(stream, " . ") < 0){ /* Improper list */ |
|
perror("print_val"); |
|
388 |
env->err= 5; |
env->err= 5; |
389 |
|
printerr(env); |
390 |
goto printval_end; |
goto printval_end; |
391 |
} |
} |
392 |
print_val(env, val, noquote, tstack, stream); |
print_val(env, val, noquote, tstack, stream); |
404 |
|
|
405 |
if(! (env->err)){ |
if(! (env->err)){ |
406 |
if(fprintf(stream, " ]") < 0){ |
if(fprintf(stream, " ]") < 0){ |
|
perror("print_val"); |
|
407 |
env->err= 5; |
env->err= 5; |
408 |
} |
} |
409 |
} |
} |
410 |
break; |
break; |
411 |
} |
} |
412 |
|
|
413 |
|
if(env->err) |
414 |
|
return printerr(env); |
415 |
} |
} |
416 |
|
|
417 |
|
|
420 |
{ |
{ |
421 |
value *temp= env->head; |
value *temp= env->head; |
422 |
|
|
423 |
if(check_args(env, unknown, unknown, empty)) |
if(check_args(env, 2, unknown, unknown)) |
424 |
return printerr(env); |
return printerr(env); |
425 |
|
|
426 |
env->head= CDR(env->head); |
env->head= CDR(env->head); |
434 |
{ |
{ |
435 |
value *val; |
value *val; |
436 |
|
|
437 |
if(check_args(env, symb, empty)) |
if(check_args(env, 1, symb)) |
438 |
return printerr(env); |
return printerr(env); |
439 |
|
|
440 |
val= CAR(env->head)->content.sym->val; |
val= CAR(env->head)->content.sym->val; |
463 |
|
|
464 |
gc_maybe(env); |
gc_maybe(env); |
465 |
|
|
466 |
if(check_args(env, unknown, empty)) |
if(check_args(env, 1, unknown)) |
467 |
return printerr(env); |
return printerr(env); |
468 |
|
|
469 |
switch(CAR(env->head)->type) { |
switch(CAR(env->head)->type) { |
658 |
if(fgets(in_string, 100, stream)==NULL) { |
if(fgets(in_string, 100, stream)==NULL) { |
659 |
push_cstring(env, ""); |
push_cstring(env, ""); |
660 |
if (! feof(stream)){ |
if (! feof(stream)){ |
|
perror("readline"); |
|
661 |
env->err= 5; |
env->err= 5; |
662 |
|
return printerr(env); |
663 |
} |
} |
664 |
} else { |
} else { |
665 |
push_cstring(env, in_string); |
push_cstring(env, in_string); |
675 |
if(CAR(env->head)->type==empty) |
if(CAR(env->head)->type==empty) |
676 |
return; /* Don't reverse an empty list */ |
return; /* Don't reverse an empty list */ |
677 |
|
|
678 |
if(check_args(env, tcons, empty)) |
if(check_args(env, 1, tcons)) |
679 |
return printerr(env); |
return printerr(env); |
680 |
|
|
681 |
old_head= CAR(env->head); |
old_head= CAR(env->head); |
815 |
} |
} |
816 |
|
|
817 |
|
|
818 |
int check_args(environment *env, ...) |
int check_args(environment *env, int num_args, ...) |
819 |
{ |
{ |
820 |
va_list ap; |
va_list ap; |
821 |
enum type_enum mytype; |
enum type_enum mytype; |
822 |
|
int i; |
823 |
|
|
824 |
value *iter= env->head; |
value *iter= env->head; |
825 |
int errval= 0; |
int errval= 0; |
826 |
|
|
827 |
va_start(ap, env); |
va_start(ap, num_args); |
828 |
while(1) { |
for(i=1; i<=num_args; i++) { |
829 |
mytype= va_arg(ap, enum type_enum); |
mytype= va_arg(ap, enum type_enum); |
830 |
// fprintf(stderr, "%s\n", env->errsymb); |
// fprintf(stderr, "%s\n", env->errsymb); |
831 |
|
|
|
if(mytype==empty) |
|
|
break; |
|
|
|
|
832 |
if(iter->type==empty || iter==NULL) { |
if(iter->type==empty || iter==NULL) { |
833 |
errval= 1; |
errval= 1; |
834 |
break; |
break; |
835 |
} |
} |
836 |
|
|
837 |
if(mytype==unknown) { |
if(mytype!=unknown && CAR(iter)->type!=mytype) { |
|
iter=CDR(iter); |
|
|
continue; |
|
|
} |
|
|
|
|
|
if(CAR(iter)->type!=mytype) { |
|
838 |
errval= 2; |
errval= 2; |
839 |
break; |
break; |
840 |
} |
} |