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 |
|
|
446 |
|
|
447 |
switch(val->type) { |
switch(val->type) { |
448 |
case empty: |
case empty: |
449 |
if(fprintf(stream, "[]") < 0){ |
if(fprintf(stream, "[]") < 0) |
|
perror("print_val"); |
|
450 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
451 |
break; |
break; |
452 |
case unknown: |
case unknown: |
453 |
if(fprintf(stream, "UNKNOWN") < 0){ |
if(fprintf(stream, "UNKNOWN") < 0) |
|
perror("print_val"); |
|
454 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
455 |
break; |
break; |
456 |
case integer: |
case integer: |
457 |
if(fprintf(stream, "%d", val->content.i) < 0){ |
if(fprintf(stream, "%d", val->content.i) < 0) |
|
perror("print_val"); |
|
458 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
459 |
break; |
break; |
460 |
case tfloat: |
case tfloat: |
461 |
if(fprintf(stream, "%f", val->content.f) < 0){ |
if(fprintf(stream, "%f", val->content.f) < 0) |
|
perror("print_val"); |
|
462 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
463 |
break; |
break; |
464 |
case string: |
case string: |
465 |
if(noquote){ |
if(noquote){ |
466 |
if(fprintf(stream, "%s", val->content.string) < 0){ |
if(fprintf(stream, "%s", val->content.string) < 0) |
|
perror("print_val"); |
|
467 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
468 |
} else { /* quote */ |
} else { /* quote */ |
469 |
if(fprintf(stream, "\"%s\"", val->content.string) < 0){ |
if(fprintf(stream, "\"%s\"", val->content.string) < 0) |
|
perror("print_val"); |
|
470 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
471 |
} |
} |
472 |
break; |
break; |
473 |
case symb: |
case symb: |
474 |
if(fprintf(stream, "%s", val->content.sym->id) < 0){ |
if(fprintf(stream, "%s", val->content.sym->id) < 0) |
|
perror("print_val"); |
|
475 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
476 |
break; |
break; |
477 |
case func: |
case func: |
478 |
if(fprintf(stream, "#<function %p>", val->content.func) < 0){ |
if(fprintf(stream, "#<function %p>", val->content.func) < 0) |
|
perror("print_val"); |
|
479 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
480 |
break; |
break; |
481 |
case port: |
case port: |
482 |
if(fprintf(stream, "#<port %p>", val->content.p) < 0){ |
if(fprintf(stream, "#<port %p>", val->content.p) < 0) |
|
perror("print_val"); |
|
483 |
env->err= 5; |
env->err= 5; |
|
return; |
|
|
} |
|
484 |
break; |
break; |
485 |
case tcons: |
case tcons: |
486 |
if(fprintf(stream, "[ ") < 0){ |
if(fprintf(stream, "[ ") < 0) { |
|
perror("print_val"); |
|
487 |
env->err= 5; |
env->err= 5; |
488 |
return; |
return printerr(env); |
489 |
} |
} |
490 |
tstack= stack; |
tstack= stack; |
491 |
|
|
507 |
|
|
508 |
if(titem != NULL){ /* If we found it on the stack, */ |
if(titem != NULL){ /* If we found it on the stack, */ |
509 |
if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */ |
if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */ |
|
perror("print_val"); |
|
510 |
env->err= 5; |
env->err= 5; |
511 |
free(titem); |
free(titem); |
512 |
return; |
return printerr(env); |
513 |
} |
} |
514 |
} else { |
} else { |
515 |
print_val(env, CAR(val), noquote, tstack, stream); |
print_val(env, CAR(val), noquote, tstack, stream); |
531 |
} |
} |
532 |
if(titem != NULL){ /* If we found it on the stack, */ |
if(titem != NULL){ /* If we found it on the stack, */ |
533 |
if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */ |
if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */ |
|
perror("print_val"); |
|
534 |
env->err= 5; |
env->err= 5; |
535 |
|
printerr(env); |
536 |
goto printval_end; |
goto printval_end; |
537 |
} |
} |
538 |
} else { |
} else { |
539 |
if(fprintf(stream, " ") < 0){ |
if(fprintf(stream, " ") < 0){ |
|
perror("print_val"); |
|
540 |
env->err= 5; |
env->err= 5; |
541 |
|
printerr(env); |
542 |
goto printval_end; |
goto printval_end; |
543 |
} |
} |
544 |
} |
} |
545 |
break; |
break; |
546 |
default: |
default: |
547 |
if(fprintf(stream, " . ") < 0){ /* Improper list */ |
if(fprintf(stream, " . ") < 0){ /* Improper list */ |
|
perror("print_val"); |
|
548 |
env->err= 5; |
env->err= 5; |
549 |
|
printerr(env); |
550 |
goto printval_end; |
goto printval_end; |
551 |
} |
} |
552 |
print_val(env, val, noquote, tstack, stream); |
print_val(env, val, noquote, tstack, stream); |
564 |
|
|
565 |
if(! (env->err)){ |
if(! (env->err)){ |
566 |
if(fprintf(stream, " ]") < 0){ |
if(fprintf(stream, " ]") < 0){ |
|
perror("print_val"); |
|
567 |
env->err= 5; |
env->err= 5; |
568 |
} |
} |
569 |
} |
} |
570 |
break; |
break; |
571 |
} |
} |
572 |
|
|
573 |
|
if(env->err) |
574 |
|
return printerr(env); |
575 |
} |
} |
576 |
|
|
577 |
|
|
579 |
extern void swap(environment *env) |
extern void swap(environment *env) |
580 |
{ |
{ |
581 |
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; |
|
|
} |
|
582 |
|
|
583 |
|
if(check_args(env, 2, unknown, unknown)) |
584 |
|
return printerr(env); |
585 |
|
|
586 |
env->head= CDR(env->head); |
env->head= CDR(env->head); |
587 |
CDR(temp)= CDR(env->head); |
CDR(temp)= CDR(env->head); |
588 |
CDR(env->head)= temp; |
CDR(env->head)= temp; |
594 |
{ |
{ |
595 |
value *val; |
value *val; |
596 |
|
|
597 |
if(env->head->type==empty) { |
if(check_args(env, 1, symb)) |
598 |
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; |
|
|
} |
|
599 |
|
|
600 |
val= CAR(env->head)->content.sym->val; |
val= CAR(env->head)->content.sym->val; |
601 |
if(val == NULL){ |
if(val == NULL){ |
|
printerr(env, "Unbound Variable"); |
|
602 |
env->err= 3; |
env->err= 3; |
603 |
return; |
return printerr(env); |
604 |
} |
} |
605 |
|
|
606 |
push_val(env, val); /* Return the symbol's bound value */ |
push_val(env, val); /* Return the symbol's bound value */ |
607 |
swap(env); |
swap(env); |
608 |
if(env->err) return; |
if(env->err) return; |
623 |
|
|
624 |
gc_maybe(env); |
gc_maybe(env); |
625 |
|
|
626 |
if(env->head->type==empty) { |
if(check_args(env, 1, unknown)) |
627 |
printerr(env, "Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
628 |
|
|
629 |
switch(CAR(env->head)->type) { |
switch(CAR(env->head)->type) { |
630 |
/* if it's a symbol */ |
/* if it's a symbol */ |
641 |
case func: |
case func: |
642 |
in_func= CAR(env->head)->content.func; |
in_func= CAR(env->head)->content.func; |
643 |
env->head= CDR(env->head); |
env->head= CDR(env->head); |
644 |
return in_func(env); |
return in_func((void*)env); |
645 |
|
|
646 |
/* If it's a list */ |
/* If it's a list */ |
647 |
case tcons: |
case tcons: |
667 |
if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons) |
if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons) |
668 |
iterator= CDR(iterator); |
iterator= CDR(iterator); |
669 |
else { |
else { |
670 |
printerr(env, "Bad Argument Type"); /* Improper list */ |
env->err= 2; /* Improper list */ |
671 |
env->err= 2; |
return printerr(env); |
|
return; |
|
672 |
} |
} |
673 |
} |
} |
674 |
unprotect(temp_val); |
unprotect(temp_val); |
737 |
} |
} |
738 |
|
|
739 |
if(myenv.interactive) |
if(myenv.interactive) |
740 |
printf(start_message); |
puts(start_message); |
741 |
|
|
742 |
while(1) { |
while(1) { |
743 |
if(myenv.in_string==NULL) { |
if(myenv.in_string==NULL) { |
818 |
if(fgets(in_string, 100, stream)==NULL) { |
if(fgets(in_string, 100, stream)==NULL) { |
819 |
push_cstring(env, ""); |
push_cstring(env, ""); |
820 |
if (! feof(stream)){ |
if (! feof(stream)){ |
|
perror("readline"); |
|
821 |
env->err= 5; |
env->err= 5; |
822 |
|
return printerr(env); |
823 |
} |
} |
824 |
} else { |
} else { |
825 |
push_cstring(env, in_string); |
push_cstring(env, in_string); |
832 |
{ |
{ |
833 |
value *old_head, *new_head, *item; |
value *old_head, *new_head, *item; |
834 |
|
|
|
if(env->head->type==empty) { |
|
|
printerr(env, "Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
835 |
if(CAR(env->head)->type==empty) |
if(CAR(env->head)->type==empty) |
836 |
return; /* Don't reverse an empty list */ |
return; /* Don't reverse an empty list */ |
837 |
|
|
838 |
if(CAR(env->head)->type!=tcons) { |
if(check_args(env, 1, tcons)) |
839 |
printerr(env, "Bad Argument Type"); |
return printerr(env); |
|
env->err= 2; |
|
|
return; |
|
|
} |
|
840 |
|
|
841 |
old_head= CAR(env->head); |
old_head= CAR(env->head); |
842 |
new_head= new_val(env); |
new_head= new_val(env); |
975 |
} |
} |
976 |
|
|
977 |
|
|
978 |
int check_args(environment *env, ...) |
int check_args(environment *env, int num_args, ...) |
979 |
{ |
{ |
980 |
va_list ap; |
va_list ap; |
981 |
enum type_enum mytype; |
enum type_enum mytype; |
982 |
|
int i; |
983 |
|
|
984 |
value *iter= env->head; |
value *iter= env->head; |
985 |
int errval= 0; |
int errval= 0; |
986 |
|
|
987 |
va_start(ap, env); |
va_start(ap, num_args); |
988 |
while(1) { |
for(i=1; i<=num_args; i++) { |
989 |
mytype= va_arg(ap, enum type_enum); |
mytype= va_arg(ap, enum type_enum); |
990 |
// fprintf(stderr, "%s\n", env->errsymb); |
// fprintf(stderr, "%s\n", env->errsymb); |
991 |
|
|
|
if(mytype==empty) |
|
|
break; |
|
|
|
|
992 |
if(iter->type==empty || iter==NULL) { |
if(iter->type==empty || iter==NULL) { |
993 |
errval= 1; |
errval= 1; |
994 |
break; |
break; |
995 |
} |
} |
996 |
|
|
997 |
if(mytype==unknown) { |
if(mytype!=unknown && CAR(iter)->type!=mytype) { |
|
iter=CDR(iter); |
|
|
continue; |
|
|
} |
|
|
|
|
|
if(CAR(iter)->type!=mytype) { |
|
998 |
errval= 2; |
errval= 2; |
999 |
break; |
break; |
1000 |
} |
} |