21 |
Teddy Hogeborn <teddy@fukt.bth.se> |
Teddy Hogeborn <teddy@fukt.bth.se> |
22 |
*/ |
*/ |
23 |
|
|
24 |
#define CAR(X) (X->content.c->car) |
#define CAR(X) ((X)->content.c->car) |
25 |
#define CDR(X) (X->content.c->cdr) |
#define CDR(X) ((X)->content.c->cdr) |
26 |
|
|
27 |
/* printf, sscanf, fgets, fprintf, fopen, perror */ |
/* printf, sscanf, fgets, fprintf, fopen, perror */ |
28 |
#include <stdio.h> |
#include <stdio.h> |
62 |
env->gc_ref= NULL; |
env->gc_ref= NULL; |
63 |
|
|
64 |
env->head= new_val(env); |
env->head= new_val(env); |
|
env->head->type= empty; |
|
65 |
for(i= 0; i<HASHTBLSIZE; i++) |
for(i= 0; i<HASHTBLSIZE; i++) |
66 |
env->symbols[i]= NULL; |
env->symbols[i]= NULL; |
67 |
env->err= 0; |
env->err= 0; |
123 |
value *nval= malloc(sizeof(value)); |
value *nval= malloc(sizeof(value)); |
124 |
stackitem *nitem= malloc(sizeof(stackitem)); |
stackitem *nitem= malloc(sizeof(stackitem)); |
125 |
|
|
126 |
|
assert(nval != NULL); |
127 |
|
assert(nitem != NULL); |
128 |
|
|
129 |
nval->content.ptr= NULL; |
nval->content.ptr= NULL; |
130 |
nval->type= integer; |
nval->type= empty; |
131 |
|
|
132 |
nitem->item= nval; |
nitem->item= nval; |
133 |
nitem->next= env->gc_ref; |
nitem->next= env->gc_ref; |
205 |
case tcons: |
case tcons: |
206 |
free(env->gc_ref->item->content.c); |
free(env->gc_ref->item->content.c); |
207 |
break; |
break; |
208 |
|
case port: |
209 |
case empty: |
case empty: |
210 |
case integer: |
case integer: |
211 |
case tfloat: |
case tfloat: |
339 |
int length= strlen(in_string)+1; |
int length= strlen(in_string)+1; |
340 |
|
|
341 |
new_value->content.ptr= malloc(length); |
new_value->content.ptr= malloc(length); |
342 |
|
assert(new_value != NULL); |
343 |
env->gc_count += length; |
env->gc_count += length; |
344 |
strcpy(new_value->content.ptr, in_string); |
strcpy(new_value->content.ptr, in_string); |
345 |
new_value->type= string; |
new_value->type= string; |
354 |
char *new_string, *current; |
char *new_string, *current; |
355 |
|
|
356 |
new_string= malloc((strlen(old_string)*2)+4); |
new_string= malloc((strlen(old_string)*2)+4); |
357 |
|
assert(new_string != NULL); |
358 |
strcpy(new_string, "sx_"); /* Stack eXternal */ |
strcpy(new_string, "sx_"); /* Stack eXternal */ |
359 |
current= new_string+3; |
current= new_string+3; |
360 |
while(old_string[0] != '\0'){ |
while(old_string[0] != '\0'){ |
424 |
|
|
425 |
/* Create a new symbol */ |
/* Create a new symbol */ |
426 |
(*new_symbol)= malloc(sizeof(symbol)); |
(*new_symbol)= malloc(sizeof(symbol)); |
427 |
|
assert((*new_symbol) != NULL); |
428 |
(*new_symbol)->val= NULL; /* undefined value */ |
(*new_symbol)->val= NULL; /* undefined value */ |
429 |
(*new_symbol)->next= NULL; |
(*new_symbol)->next= NULL; |
430 |
(*new_symbol)->id= malloc(strlen(in_string)+1); |
(*new_symbol)->id= malloc(strlen(in_string)+1); |
431 |
|
assert((*new_symbol)->id != NULL); |
432 |
strcpy((*new_symbol)->id, in_string); |
strcpy((*new_symbol)->id, in_string); |
433 |
|
|
434 |
/* Intern the new symbol in the hash table */ |
/* Intern the new symbol in the hash table */ |
463 |
} |
} |
464 |
|
|
465 |
/* Print newline. */ |
/* Print newline. */ |
466 |
extern void nl() |
extern void nl(environment *env) |
467 |
{ |
{ |
468 |
printf("\n"); |
printf("\n"); |
469 |
} |
} |
470 |
|
|
471 |
|
/* Print a newline to a port */ |
472 |
|
extern void nlport(environment *env) |
473 |
|
{ |
474 |
|
if(env->head->type==empty) { |
475 |
|
printerr("Too Few Arguments"); |
476 |
|
env->err= 1; |
477 |
|
return; |
478 |
|
} |
479 |
|
|
480 |
|
if(CAR(env->head)->type!=port) { |
481 |
|
printerr("Bad Argument Type"); |
482 |
|
env->err= 2; |
483 |
|
return; |
484 |
|
} |
485 |
|
|
486 |
|
if(fprintf(CAR(env->head)->content.p, "\n") < 0){ |
487 |
|
perror("nl"); |
488 |
|
env->err= 5; |
489 |
|
return; |
490 |
|
} |
491 |
|
toss(env); |
492 |
|
} |
493 |
|
|
494 |
/* Gets the type of a value */ |
/* Gets the type of a value */ |
495 |
extern void type(environment *env) |
extern void type(environment *env) |
496 |
{ |
{ |
522 |
case tcons: |
case tcons: |
523 |
push_sym(env, "pair"); |
push_sym(env, "pair"); |
524 |
break; |
break; |
525 |
|
case port: |
526 |
|
push_sym(env, "port"); |
527 |
|
break; |
528 |
} |
} |
529 |
swap(env); |
swap(env); |
530 |
if (env->err) return; |
if (env->err) return; |
531 |
toss(env); |
toss(env); |
532 |
} |
} |
533 |
|
|
534 |
/* Print a value */ |
/* Print a value */ |
535 |
void print_val(value *val, int noquote) |
void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream) |
536 |
{ |
{ |
537 |
|
stackitem *titem, *tstack; |
538 |
|
int depth; |
539 |
|
|
540 |
switch(val->type) { |
switch(val->type) { |
541 |
case empty: |
case empty: |
542 |
printf("[]"); |
if(fprintf(stream, "[]") < 0){ |
543 |
|
perror("print_val"); |
544 |
|
env->err= 5; |
545 |
|
return; |
546 |
|
} |
547 |
break; |
break; |
548 |
case integer: |
case integer: |
549 |
printf("%d", val->content.i); |
if(fprintf(stream, "%d", val->content.i) < 0){ |
550 |
|
perror("print_val"); |
551 |
|
env->err= 5; |
552 |
|
return; |
553 |
|
} |
554 |
break; |
break; |
555 |
case tfloat: |
case tfloat: |
556 |
printf("%f", val->content.f); |
if(fprintf(stream, "%f", val->content.f) < 0){ |
557 |
|
perror("print_val"); |
558 |
|
env->err= 5; |
559 |
|
return; |
560 |
|
} |
561 |
break; |
break; |
562 |
case string: |
case string: |
563 |
if(noquote) |
if(noquote){ |
564 |
printf("%s", (char*)(val->content.ptr)); |
if(fprintf(stream, "%s", (char*)(val->content.ptr)) < 0){ |
565 |
else |
perror("print_val"); |
566 |
printf("\"%s\"", (char*)(val->content.ptr)); |
env->err= 5; |
567 |
|
return; |
568 |
|
} |
569 |
|
} else { /* quote */ |
570 |
|
if(fprintf(stream, "\"%s\"", (char*)(val->content.ptr)) < 0){ |
571 |
|
perror("print_val"); |
572 |
|
env->err= 5; |
573 |
|
return; |
574 |
|
} |
575 |
|
} |
576 |
break; |
break; |
577 |
case symb: |
case symb: |
578 |
printf("%s", val->content.sym->id); |
if(fprintf(stream, "%s", val->content.sym->id) < 0){ |
579 |
|
perror("print_val"); |
580 |
|
env->err= 5; |
581 |
|
return; |
582 |
|
} |
583 |
break; |
break; |
584 |
case func: |
case func: |
585 |
printf("#<function %p>", (funcp)(val->content.ptr)); |
if(fprintf(stream, "#<function %p>", (funcp)(val->content.ptr)) < 0){ |
586 |
|
perror("print_val"); |
587 |
|
env->err= 5; |
588 |
|
return; |
589 |
|
} |
590 |
|
break; |
591 |
|
case port: |
592 |
|
if(fprintf(stream, "#<port %p>", (funcp)(val->content.p)) < 0){ |
593 |
|
perror("print_val"); |
594 |
|
env->err= 5; |
595 |
|
return; |
596 |
|
} |
597 |
break; |
break; |
598 |
case tcons: |
case tcons: |
599 |
printf("[ "); |
if(fprintf(stream, "[ ") < 0){ |
600 |
|
perror("print_val"); |
601 |
|
env->err= 5; |
602 |
|
return; |
603 |
|
} |
604 |
|
tstack= stack; |
605 |
do { |
do { |
606 |
print_val(CAR(val), noquote); |
titem=malloc(sizeof(stackitem)); |
607 |
|
assert(titem != NULL); |
608 |
|
titem->item=val; |
609 |
|
titem->next=tstack; |
610 |
|
tstack=titem; /* Put it on the stack */ |
611 |
|
/* Search a stack of values being printed to see if we are already |
612 |
|
printing this value */ |
613 |
|
titem=tstack; |
614 |
|
depth=0; |
615 |
|
while(titem != NULL && titem->item != CAR(val)){ |
616 |
|
titem=titem->next; |
617 |
|
depth++; |
618 |
|
} |
619 |
|
if(titem != NULL){ /* If we found it on the stack, */ |
620 |
|
if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */ |
621 |
|
perror("print_val"); |
622 |
|
env->err= 5; |
623 |
|
free(titem); |
624 |
|
return; |
625 |
|
} |
626 |
|
} else { |
627 |
|
print_val(env, CAR(val), noquote, tstack, stream); |
628 |
|
} |
629 |
val= CDR(val); |
val= CDR(val); |
630 |
switch(val->type){ |
switch(val->type){ |
631 |
case empty: |
case empty: |
632 |
break; |
break; |
633 |
case tcons: |
case tcons: |
634 |
printf(" "); |
/* Search a stack of values being printed to see if we are already |
635 |
|
printing this value */ |
636 |
|
titem=tstack; |
637 |
|
depth=0; |
638 |
|
while(titem != NULL && titem->item != val){ |
639 |
|
titem=titem->next; |
640 |
|
depth++; |
641 |
|
} |
642 |
|
if(titem != NULL){ /* If we found it on the stack, */ |
643 |
|
if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */ |
644 |
|
perror("print_val"); |
645 |
|
env->err= 5; |
646 |
|
goto printval_end; |
647 |
|
} |
648 |
|
} else { |
649 |
|
if(fprintf(stream, " ") < 0){ |
650 |
|
perror("print_val"); |
651 |
|
env->err= 5; |
652 |
|
goto printval_end; |
653 |
|
} |
654 |
|
} |
655 |
break; |
break; |
656 |
default: |
default: |
657 |
printf(" . "); /* Improper list */ |
if(fprintf(stream, " . ") < 0){ /* Improper list */ |
658 |
print_val(val, noquote); |
perror("print_val"); |
659 |
|
env->err= 5; |
660 |
|
goto printval_end; |
661 |
|
} |
662 |
|
print_val(env, val, noquote, tstack, stream); |
663 |
|
} |
664 |
|
} while(val->type == tcons && titem == NULL); |
665 |
|
|
666 |
|
printval_end: |
667 |
|
|
668 |
|
titem=tstack; |
669 |
|
while(titem != stack){ |
670 |
|
tstack=titem->next; |
671 |
|
free(titem); |
672 |
|
titem=tstack; |
673 |
|
} |
674 |
|
|
675 |
|
if(! (env->err)){ |
676 |
|
if(fprintf(stream, " ]") < 0){ |
677 |
|
perror("print_val"); |
678 |
|
env->err= 5; |
679 |
} |
} |
680 |
} while(val->type == tcons); |
} |
|
printf(" ]"); |
|
681 |
break; |
break; |
682 |
} |
} |
683 |
} |
} |
684 |
|
|
685 |
|
/* Print the top element of the stack but don't discard it */ |
686 |
extern void print_(environment *env) |
extern void print_(environment *env) |
687 |
{ |
{ |
688 |
if(env->head->type==empty) { |
if(env->head->type==empty) { |
690 |
env->err= 1; |
env->err= 1; |
691 |
return; |
return; |
692 |
} |
} |
693 |
print_val(CAR(env->head), 0); |
print_val(env, CAR(env->head), 0, NULL, stdout); |
694 |
nl(); |
if(env->err) return; |
695 |
|
nl(env); |
696 |
} |
} |
697 |
|
|
698 |
/* Prints the top element of the stack and then discards it. */ |
/* Prints the top element of the stack */ |
699 |
extern void print(environment *env) |
extern void print(environment *env) |
700 |
{ |
{ |
701 |
print_(env); |
print_(env); |
703 |
toss(env); |
toss(env); |
704 |
} |
} |
705 |
|
|
706 |
|
/* Print the top element of the stack without quotes, but don't |
707 |
|
discard it. */ |
708 |
extern void princ_(environment *env) |
extern void princ_(environment *env) |
709 |
{ |
{ |
710 |
if(env->head->type==empty) { |
if(env->head->type==empty) { |
712 |
env->err= 1; |
env->err= 1; |
713 |
return; |
return; |
714 |
} |
} |
715 |
print_val(CAR(env->head), 1); |
print_val(env, CAR(env->head), 1, NULL, stdout); |
716 |
} |
} |
717 |
|
|
718 |
/* Prints the top element of the stack and then discards it. */ |
/* Prints the top element of the stack without quotes. */ |
719 |
extern void princ(environment *env) |
extern void princ(environment *env) |
720 |
{ |
{ |
721 |
princ_(env); |
princ_(env); |
723 |
toss(env); |
toss(env); |
724 |
} |
} |
725 |
|
|
726 |
/* Only to be called by function printstack. */ |
/* Print a value to a port, but don't discard it */ |
727 |
void print_st(value *stack_head, long counter) |
extern void printport_(environment *env) |
728 |
|
{ |
729 |
|
if(env->head->type==empty || CDR(env->head)->type == empty) { |
730 |
|
printerr("Too Few Arguments"); |
731 |
|
env->err= 1; |
732 |
|
return; |
733 |
|
} |
734 |
|
|
735 |
|
if(CAR(env->head)->type!=port) { |
736 |
|
printerr("Bad Argument Type"); |
737 |
|
env->err= 2; |
738 |
|
return; |
739 |
|
} |
740 |
|
|
741 |
|
print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p); |
742 |
|
if(env->err) return; |
743 |
|
nlport(env); |
744 |
|
} |
745 |
|
|
746 |
|
/* Print a value to a port */ |
747 |
|
extern void printport(environment *env) |
748 |
|
{ |
749 |
|
printport_(env); |
750 |
|
if(env->err) return; |
751 |
|
toss(env); |
752 |
|
} |
753 |
|
|
754 |
|
/* Print, without quotes, to a port, a value, but don't discard it. */ |
755 |
|
extern void princport_(environment *env) |
756 |
|
{ |
757 |
|
if(env->head->type==empty || CDR(env->head)->type == empty) { |
758 |
|
printerr("Too Few Arguments"); |
759 |
|
env->err= 1; |
760 |
|
return; |
761 |
|
} |
762 |
|
|
763 |
|
if(CAR(env->head)->type!=port) { |
764 |
|
printerr("Bad Argument Type"); |
765 |
|
env->err= 2; |
766 |
|
return; |
767 |
|
} |
768 |
|
|
769 |
|
print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p); |
770 |
|
toss(env); if(env->err) return; |
771 |
|
} |
772 |
|
|
773 |
|
/* Print, without quotes, to a port, the top element. */ |
774 |
|
extern void princport(environment *env) |
775 |
|
{ |
776 |
|
princport_(env); |
777 |
|
if(env->err) return; |
778 |
|
toss(env); |
779 |
|
} |
780 |
|
|
781 |
|
/* Only to be called by itself function printstack. */ |
782 |
|
void print_st(environment *env, value *stack_head, long counter) |
783 |
{ |
{ |
784 |
if(CDR(stack_head)->type != empty) |
if(CDR(stack_head)->type != empty) |
785 |
print_st(CDR(stack_head), counter+1); |
print_st(env, CDR(stack_head), counter+1); |
786 |
printf("%ld: ", counter); |
printf("%ld: ", counter); |
787 |
print_val(CAR(stack_head), 0); |
print_val(env, CAR(stack_head), 0, NULL, stdout); |
788 |
nl(); |
nl(env); |
789 |
} |
} |
790 |
|
|
791 |
/* Prints the stack. */ |
/* Prints the stack. */ |
796 |
return; |
return; |
797 |
} |
} |
798 |
|
|
799 |
print_st(env->head, 1); |
print_st(env, env->head, 1); |
800 |
} |
} |
801 |
|
|
802 |
/* Swap the two top elements on the stack. */ |
/* Swap the two top elements on the stack. */ |
932 |
return; |
return; |
933 |
|
|
934 |
case empty: |
case empty: |
935 |
|
toss(env); |
936 |
case integer: |
case integer: |
937 |
case tfloat: |
case tfloat: |
938 |
case string: |
case string: |
939 |
|
case port: |
940 |
return; |
return; |
941 |
} |
} |
942 |
} |
} |
963 |
|
|
964 |
old_head= CAR(env->head); |
old_head= CAR(env->head); |
965 |
new_head= new_val(env); |
new_head= new_val(env); |
|
new_head->type= empty; |
|
966 |
while(old_head->type != empty) { |
while(old_head->type != empty) { |
967 |
item= old_head; |
item= old_head; |
968 |
old_head= CDR(old_head); |
old_head= CDR(old_head); |
978 |
value *iterator, *temp, *ending; |
value *iterator, *temp, *ending; |
979 |
|
|
980 |
ending=new_val(env); |
ending=new_val(env); |
|
ending->type=empty; |
|
981 |
|
|
982 |
iterator= env->head; |
iterator= env->head; |
983 |
if(iterator->type == empty |
if(iterator->type == empty |
1275 |
if (myenv.interactive) { |
if (myenv.interactive) { |
1276 |
if(myenv.err) { |
if(myenv.err) { |
1277 |
printf("(error %d)\n", myenv.err); |
printf("(error %d)\n", myenv.err); |
1278 |
|
myenv.err= 0; |
1279 |
} |
} |
1280 |
nl(); |
nl(&myenv); |
1281 |
printstack(&myenv); |
printstack(&myenv); |
1282 |
printf("> "); |
printf("> "); |
1283 |
} |
} |
1289 |
quit(&myenv); |
quit(&myenv); |
1290 |
} else if(myenv.head->type!=empty |
} else if(myenv.head->type!=empty |
1291 |
&& CAR(myenv.head)->type==symb |
&& CAR(myenv.head)->type==symb |
1292 |
&& CAR(myenv.head)->content.sym->id[0] |
&& CAR(myenv.head)->content.sym->id[0] == ';') { |
|
==';') { |
|
1293 |
toss(&myenv); /* No error check in main */ |
toss(&myenv); /* No error check in main */ |
1294 |
eval(&myenv); |
eval(&myenv); |
1295 |
} |
} |
1323 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1324 |
len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1; |
len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1; |
1325 |
new_string= malloc(len); |
new_string= malloc(len); |
1326 |
|
assert(new_string != NULL); |
1327 |
strcpy(new_string, b_val->content.ptr); |
strcpy(new_string, b_val->content.ptr); |
1328 |
strcat(new_string, a_val->content.ptr); |
strcat(new_string, a_val->content.ptr); |
1329 |
push_cstring(env, new_string); |
push_cstring(env, new_string); |
1530 |
if(old_value==NULL) |
if(old_value==NULL) |
1531 |
return NULL; |
return NULL; |
1532 |
|
|
|
protect(old_value); |
|
1533 |
new_value= new_val(env); |
new_value= new_val(env); |
1534 |
new_value->type= old_value->type; |
new_value->type= old_value->type; |
1535 |
|
|
1539 |
case func: |
case func: |
1540 |
case symb: |
case symb: |
1541 |
case empty: |
case empty: |
1542 |
|
case port: |
1543 |
new_value->content= old_value->content; |
new_value->content= old_value->content; |
1544 |
break; |
break; |
1545 |
case string: |
case string: |
1557 |
break; |
break; |
1558 |
} |
} |
1559 |
|
|
|
unprotect(old_value); |
|
|
|
|
1560 |
return new_value; |
return new_value; |
1561 |
} |
} |
1562 |
|
|
1638 |
eval(env); |
eval(env); |
1639 |
} |
} |
1640 |
|
|
1641 |
|
/* "else" */ |
1642 |
extern void sx_656c7365(environment *env) |
extern void sx_656c7365(environment *env) |
1643 |
{ |
{ |
1644 |
if(env->head->type==empty || CDR(env->head)->type==empty |
if(env->head->type==empty || CDR(env->head)->type==empty |
1804 |
|
|
1805 |
iterator= foo; |
iterator= foo; |
1806 |
|
|
1807 |
while(iterator!=NULL) { |
while(iterator->type!=empty) { |
1808 |
push_val(env, CAR(iterator)); |
push_val(env, CAR(iterator)); |
1809 |
push_val(env, loop); |
push_val(env, loop); |
1810 |
eval(env); if(env->err) return; |
eval(env); if(env->err) return; |
1823 |
extern void to(environment *env) |
extern void to(environment *env) |
1824 |
{ |
{ |
1825 |
int ending, start, i; |
int ending, start, i; |
1826 |
value *iterator, *temp; |
value *iterator, *temp, *end; |
1827 |
|
|
1828 |
|
end= new_val(env); |
1829 |
|
|
1830 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
1831 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1860 |
if(iterator->type==empty |
if(iterator->type==empty |
1861 |
|| (CAR(iterator)->type==symb |
|| (CAR(iterator)->type==symb |
1862 |
&& CAR(iterator)->content.sym->id[0]=='[')) { |
&& CAR(iterator)->content.sym->id[0]=='[')) { |
1863 |
temp= NULL; |
temp= end; |
1864 |
toss(env); |
toss(env); |
1865 |
} else { |
} else { |
1866 |
/* Search for first delimiter */ |
/* Search for first delimiter */ |
1867 |
while(CDR(iterator)!=NULL |
while(CDR(iterator)->type!=empty |
1868 |
&& (CAR(CDR(iterator))->type!=symb |
&& (CAR(CDR(iterator))->type!=symb |
1869 |
|| CAR(CDR(iterator))->content.sym->id[0]!='[')) |
|| CAR(CDR(iterator))->content.sym->id[0]!='[')) |
1870 |
iterator= CDR(iterator); |
iterator= CDR(iterator); |
1872 |
/* Extract list */ |
/* Extract list */ |
1873 |
temp= env->head; |
temp= env->head; |
1874 |
env->head= CDR(iterator); |
env->head= CDR(iterator); |
1875 |
CDR(iterator)= NULL; |
CDR(iterator)= end; |
1876 |
|
|
1877 |
if(env->head!=NULL) |
if(env->head->type!=empty) |
1878 |
toss(env); |
toss(env); |
1879 |
} |
} |
1880 |
|
|
1885 |
/* Read a string */ |
/* Read a string */ |
1886 |
extern void readline(environment *env) |
extern void readline(environment *env) |
1887 |
{ |
{ |
1888 |
|
readlinestream(env, env->inputstream); |
1889 |
|
} |
1890 |
|
|
1891 |
|
/* Read a string from a port */ |
1892 |
|
extern void readlineport(environment *env) |
1893 |
|
{ |
1894 |
|
FILE *stream; |
1895 |
|
|
1896 |
|
if(env->head->type==empty) { |
1897 |
|
printerr("Too Few Arguments"); |
1898 |
|
env->err= 1; |
1899 |
|
return; |
1900 |
|
} |
1901 |
|
|
1902 |
|
if(CAR(env->head)->type!=port) { |
1903 |
|
printerr("Bad Argument Type"); |
1904 |
|
env->err= 2; |
1905 |
|
return; |
1906 |
|
} |
1907 |
|
|
1908 |
|
stream=CAR(env->head)->content.p; |
1909 |
|
readlinestream(env, stream); if(env->err) return; |
1910 |
|
|
1911 |
|
swap(env); if(env->err) return; |
1912 |
|
toss(env); |
1913 |
|
} |
1914 |
|
|
1915 |
|
/* read a line from a stream; used by readline */ |
1916 |
|
void readlinestream(environment *env, FILE *stream) |
1917 |
|
{ |
1918 |
char in_string[101]; |
char in_string[101]; |
1919 |
|
|
1920 |
if(fgets(in_string, 100, env->inputstream)==NULL) |
if(fgets(in_string, 100, stream)==NULL) { |
1921 |
push_cstring(env, ""); |
push_cstring(env, ""); |
1922 |
else |
if (! feof(stream)){ |
1923 |
|
perror("readline"); |
1924 |
|
env->err= 5; |
1925 |
|
} |
1926 |
|
} else { |
1927 |
push_cstring(env, in_string); |
push_cstring(env, in_string); |
1928 |
|
} |
1929 |
} |
} |
1930 |
|
|
1931 |
/* "read"; Read a value and place on stack */ |
/* "read"; Read a value and place on stack */ |
1932 |
extern void sx_72656164(environment *env) |
extern void sx_72656164(environment *env) |
1933 |
{ |
{ |
1934 |
|
readstream(env, env->inputstream); |
1935 |
|
} |
1936 |
|
|
1937 |
|
/* "readport"; Read a value from a port and place on stack */ |
1938 |
|
extern void readport(environment *env) |
1939 |
|
{ |
1940 |
|
FILE *stream; |
1941 |
|
|
1942 |
|
if(env->head->type==empty) { |
1943 |
|
printerr("Too Few Arguments"); |
1944 |
|
env->err= 1; |
1945 |
|
return; |
1946 |
|
} |
1947 |
|
|
1948 |
|
if(CAR(env->head)->type!=port) { |
1949 |
|
printerr("Bad Argument Type"); |
1950 |
|
env->err= 2; |
1951 |
|
return; |
1952 |
|
} |
1953 |
|
|
1954 |
|
stream=CAR(env->head)->content.p; |
1955 |
|
readstream(env, stream); if(env->err) return; |
1956 |
|
|
1957 |
|
swap(env); if(env->err) return; |
1958 |
|
toss(env); |
1959 |
|
} |
1960 |
|
|
1961 |
|
/* read from a stream; used by "read" and "readport" */ |
1962 |
|
void readstream(environment *env, FILE *stream) |
1963 |
|
{ |
1964 |
const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n"; |
const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n"; |
1965 |
const char strform[]= "\"%[^\"]\"%n"; |
const char strform[]= "\"%[^\"]\"%n"; |
1966 |
const char intform[]= "%i%n"; |
const char intform[]= "%i%n"; |
1989 |
} |
} |
1990 |
|
|
1991 |
env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1); |
env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1); |
1992 |
|
assert(env->in_string != NULL); |
1993 |
env->free_string= env->in_string; /* Save the original pointer */ |
env->free_string= env->in_string; /* Save the original pointer */ |
1994 |
strcpy(env->in_string, CAR(env->head)->content.ptr); |
strcpy(env->in_string, CAR(env->head)->content.ptr); |
1995 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1997 |
|
|
1998 |
inlength= strlen(env->in_string)+1; |
inlength= strlen(env->in_string)+1; |
1999 |
match= malloc(inlength); |
match= malloc(inlength); |
2000 |
|
assert(match != NULL); |
2001 |
|
|
2002 |
if(sscanf(env->in_string, blankform, &readlength) != EOF |
if(sscanf(env->in_string, blankform, &readlength) != EOF |
2003 |
&& readlength != -1) { |
&& readlength != -1) { |
2666 |
swap(env); if(env->err) return; |
swap(env); if(env->err) return; |
2667 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
2668 |
} |
} |
2669 |
|
|
2670 |
|
/* 2: 3 => */ |
2671 |
|
/* 1: [ [ 1 . 2 ] [ 3 . 4 ] ] => 1: [ 3 . 4 ] */ |
2672 |
|
extern void assq(environment *env) |
2673 |
|
{ |
2674 |
|
assocgen(env, eq); |
2675 |
|
} |
2676 |
|
|
2677 |
|
|
2678 |
|
/* General assoc function */ |
2679 |
|
void assocgen(environment *env, funcp eqfunc) |
2680 |
|
{ |
2681 |
|
value *key, *item; |
2682 |
|
|
2683 |
|
/* Needs two values on the stack, the top one must be an association |
2684 |
|
list */ |
2685 |
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
2686 |
|
printerr("Too Few Arguments"); |
2687 |
|
env->err= 1; |
2688 |
|
return; |
2689 |
|
} |
2690 |
|
|
2691 |
|
if(CAR(env->head)->type!=tcons) { |
2692 |
|
printerr("Bad Argument Type"); |
2693 |
|
env->err= 2; |
2694 |
|
return; |
2695 |
|
} |
2696 |
|
|
2697 |
|
key=CAR(CDR(env->head)); |
2698 |
|
item=CAR(env->head); |
2699 |
|
|
2700 |
|
while(item->type == tcons){ |
2701 |
|
if(CAR(item)->type != tcons){ |
2702 |
|
printerr("Bad Argument Type"); |
2703 |
|
env->err= 2; |
2704 |
|
return; |
2705 |
|
} |
2706 |
|
push_val(env, key); |
2707 |
|
push_val(env, CAR(CAR(item))); |
2708 |
|
eqfunc(env); if(env->err) return; |
2709 |
|
|
2710 |
|
/* Check the result of 'eqfunc' */ |
2711 |
|
if(env->head->type==empty) { |
2712 |
|
printerr("Too Few Arguments"); |
2713 |
|
env->err= 1; |
2714 |
|
return; |
2715 |
|
} |
2716 |
|
if(CAR(env->head)->type!=integer) { |
2717 |
|
printerr("Bad Argument Type"); |
2718 |
|
env->err= 2; |
2719 |
|
return; |
2720 |
|
} |
2721 |
|
|
2722 |
|
if(CAR(env->head)->content.i){ |
2723 |
|
toss(env); if(env->err) return; |
2724 |
|
break; |
2725 |
|
} |
2726 |
|
toss(env); if(env->err) return; |
2727 |
|
|
2728 |
|
if(item->type!=tcons) { |
2729 |
|
printerr("Bad Argument Type"); |
2730 |
|
env->err= 2; |
2731 |
|
return; |
2732 |
|
} |
2733 |
|
|
2734 |
|
item=CDR(item); |
2735 |
|
} |
2736 |
|
|
2737 |
|
if(item->type == tcons){ /* A match was found */ |
2738 |
|
push_val(env, CAR(item)); |
2739 |
|
} else { |
2740 |
|
push_int(env, 0); |
2741 |
|
} |
2742 |
|
swap(env); if(env->err) return; |
2743 |
|
toss(env); if(env->err) return; |
2744 |
|
swap(env); if(env->err) return; |
2745 |
|
toss(env); |
2746 |
|
} |
2747 |
|
|
2748 |
|
/* "do" */ |
2749 |
|
extern void sx_646f(environment *env) |
2750 |
|
{ |
2751 |
|
swap(env); if(env->err) return; |
2752 |
|
eval(env); |
2753 |
|
} |
2754 |
|
|
2755 |
|
/* "open" */ |
2756 |
|
/* 2: "file" */ |
2757 |
|
/* 1: "r" => 1: #<port 0x47114711> */ |
2758 |
|
extern void sx_6f70656e(environment *env) |
2759 |
|
{ |
2760 |
|
value *new_port; |
2761 |
|
FILE *stream; |
2762 |
|
|
2763 |
|
if(env->head->type == empty || CDR(env->head)->type == empty) { |
2764 |
|
printerr("Too Few Arguments"); |
2765 |
|
env->err=1; |
2766 |
|
return; |
2767 |
|
} |
2768 |
|
|
2769 |
|
if(CAR(env->head)->type != string |
2770 |
|
|| CAR(CDR(env->head))->type != string) { |
2771 |
|
printerr("Bad Argument Type"); |
2772 |
|
env->err= 2; |
2773 |
|
return; |
2774 |
|
} |
2775 |
|
|
2776 |
|
stream=fopen(CAR(CDR(env->head))->content.ptr, |
2777 |
|
CAR(env->head)->content.ptr); |
2778 |
|
|
2779 |
|
if(stream == NULL) { |
2780 |
|
perror("open"); |
2781 |
|
env->err= 5; |
2782 |
|
return; |
2783 |
|
} |
2784 |
|
|
2785 |
|
new_port=new_val(env); |
2786 |
|
new_port->type=port; |
2787 |
|
new_port->content.p=stream; |
2788 |
|
|
2789 |
|
push_val(env, new_port); |
2790 |
|
|
2791 |
|
swap(env); if(env->err) return; |
2792 |
|
toss(env); if(env->err) return; |
2793 |
|
swap(env); if(env->err) return; |
2794 |
|
toss(env); |
2795 |
|
} |
2796 |
|
|
2797 |
|
|
2798 |
|
/* "close" */ |
2799 |
|
extern void sx_636c6f7365(environment *env) |
2800 |
|
{ |
2801 |
|
int ret; |
2802 |
|
|
2803 |
|
if(env->head->type == empty) { |
2804 |
|
printerr("Too Few Arguments"); |
2805 |
|
env->err=1; |
2806 |
|
return; |
2807 |
|
} |
2808 |
|
|
2809 |
|
if(CAR(env->head)->type != port) { |
2810 |
|
printerr("Bad Argument Type"); |
2811 |
|
env->err= 2; |
2812 |
|
return; |
2813 |
|
} |
2814 |
|
|
2815 |
|
ret= fclose(CAR(env->head)->content.p); |
2816 |
|
|
2817 |
|
if(ret != 0){ |
2818 |
|
perror("close"); |
2819 |
|
env->err= 5; |
2820 |
|
return; |
2821 |
|
} |
2822 |
|
|
2823 |
|
toss(env); |
2824 |
|
} |