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 */ |
50 |
} |
} |
51 |
|
|
52 |
|
|
53 |
void printerr(environment *env, const char* in_string) |
void printerr(environment *env) |
54 |
{ |
{ |
55 |
|
char *in_string; |
56 |
|
|
57 |
|
switch(env->err) { |
58 |
|
case 0: |
59 |
|
return; |
60 |
|
case 1: |
61 |
|
in_string= "Too Few Arguments"; |
62 |
|
break; |
63 |
|
case 2: |
64 |
|
in_string= "Bad Argument Type"; |
65 |
|
break; |
66 |
|
case 3: |
67 |
|
in_string= "Unbound Variable"; |
68 |
|
break; |
69 |
|
case 5: |
70 |
|
return perror(env->errsymb); |
71 |
|
default: |
72 |
|
in_string= "Unknown error"; |
73 |
|
break; |
74 |
|
} |
75 |
|
|
76 |
fprintf(stderr, "\"%s\":\nErr: %s\n", env->errsymb, in_string); |
fprintf(stderr, "\"%s\":\nErr: %s\n", env->errsymb, in_string); |
77 |
} |
} |
78 |
|
|
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 |
|
|
419 |
extern void swap(environment *env) |
extern void swap(environment *env) |
420 |
{ |
{ |
421 |
value *temp= env->head; |
value *temp= env->head; |
|
|
|
|
if(env->head->type == empty || CDR(env->head)->type == empty) { |
|
|
printerr(env, "Too Few Arguments"); |
|
|
env->err=1; |
|
|
return; |
|
|
} |
|
422 |
|
|
423 |
|
if(check_args(env, 2, unknown, unknown)) |
424 |
|
return printerr(env); |
425 |
|
|
426 |
env->head= CDR(env->head); |
env->head= CDR(env->head); |
427 |
CDR(temp)= CDR(env->head); |
CDR(temp)= CDR(env->head); |
428 |
CDR(env->head)= temp; |
CDR(env->head)= temp; |
434 |
{ |
{ |
435 |
value *val; |
value *val; |
436 |
|
|
437 |
if(env->head->type==empty) { |
if(check_args(env, 1, symb)) |
438 |
printerr(env, "Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type!=symb) { |
|
|
printerr(env, "Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
439 |
|
|
440 |
val= CAR(env->head)->content.sym->val; |
val= CAR(env->head)->content.sym->val; |
441 |
if(val == NULL){ |
if(val == NULL){ |
|
printerr(env, "Unbound Variable"); |
|
442 |
env->err= 3; |
env->err= 3; |
443 |
return; |
return printerr(env); |
444 |
} |
} |
445 |
|
|
446 |
push_val(env, val); /* Return the symbol's bound value */ |
push_val(env, val); /* Return the symbol's bound value */ |
447 |
swap(env); |
swap(env); |
448 |
if(env->err) return; |
if(env->err) return; |
463 |
|
|
464 |
gc_maybe(env); |
gc_maybe(env); |
465 |
|
|
466 |
if(env->head->type==empty) { |
if(check_args(env, 1, unknown)) |
467 |
printerr(env, "Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
468 |
|
|
469 |
switch(CAR(env->head)->type) { |
switch(CAR(env->head)->type) { |
470 |
/* if it's a symbol */ |
/* if it's a symbol */ |
481 |
case func: |
case func: |
482 |
in_func= CAR(env->head)->content.func; |
in_func= CAR(env->head)->content.func; |
483 |
env->head= CDR(env->head); |
env->head= CDR(env->head); |
484 |
return in_func(env); |
return in_func((void*)env); |
485 |
|
|
486 |
/* If it's a list */ |
/* If it's a list */ |
487 |
case tcons: |
case tcons: |
507 |
if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons) |
if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons) |
508 |
iterator= CDR(iterator); |
iterator= CDR(iterator); |
509 |
else { |
else { |
510 |
printerr(env, "Bad Argument Type"); /* Improper list */ |
env->err= 2; /* Improper list */ |
511 |
env->err= 2; |
return printerr(env); |
|
return; |
|
512 |
} |
} |
513 |
} |
} |
514 |
unprotect(temp_val); |
unprotect(temp_val); |
577 |
} |
} |
578 |
|
|
579 |
if(myenv.interactive) |
if(myenv.interactive) |
580 |
printf(start_message); |
puts(start_message); |
581 |
|
|
582 |
while(1) { |
while(1) { |
583 |
if(myenv.in_string==NULL) { |
if(myenv.in_string==NULL) { |
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); |
672 |
{ |
{ |
673 |
value *old_head, *new_head, *item; |
value *old_head, *new_head, *item; |
674 |
|
|
|
if(env->head->type==empty) { |
|
|
printerr(env, "Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
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(CAR(env->head)->type!=tcons) { |
if(check_args(env, 1, tcons)) |
679 |
printerr(env, "Bad Argument Type"); |
return printerr(env); |
|
env->err= 2; |
|
|
return; |
|
|
} |
|
680 |
|
|
681 |
old_head= CAR(env->head); |
old_head= CAR(env->head); |
682 |
new_head= new_val(env); |
new_head= new_val(env); |
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 |
} |
} |