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: |
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, stackitem *stack) |
void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream) |
536 |
{ |
{ |
537 |
stackitem *titem, *tstack; |
stackitem *titem, *tstack; |
538 |
int depth; |
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; |
tstack= stack; |
605 |
do { |
do { |
606 |
titem=malloc(sizeof(stackitem)); |
titem=malloc(sizeof(stackitem)); |
617 |
depth++; |
depth++; |
618 |
} |
} |
619 |
if(titem != NULL){ /* If we found it on the stack, */ |
if(titem != NULL){ /* If we found it on the stack, */ |
620 |
printf("#%d#", depth); /* print a depth reference */ |
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 { |
} else { |
627 |
print_val(CAR(val), noquote, tstack); |
print_val(env, CAR(val), noquote, tstack, stream); |
628 |
} |
} |
629 |
val= CDR(val); |
val= CDR(val); |
630 |
switch(val->type){ |
switch(val->type){ |
640 |
depth++; |
depth++; |
641 |
} |
} |
642 |
if(titem != NULL){ /* If we found it on the stack, */ |
if(titem != NULL){ /* If we found it on the stack, */ |
643 |
printf(" . #%d#", depth); /* print a depth reference */ |
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 { |
} else { |
649 |
printf(" "); |
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, tstack); |
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); |
} while(val->type == tcons && titem == NULL); |
665 |
|
|
666 |
|
printval_end: |
667 |
|
|
668 |
titem=tstack; |
titem=tstack; |
669 |
while(titem != stack){ |
while(titem != stack){ |
670 |
tstack=titem->next; |
tstack=titem->next; |
671 |
free(titem); |
free(titem); |
672 |
titem=tstack; |
titem=tstack; |
673 |
} |
} |
674 |
printf(" ]"); |
|
675 |
|
if(! (env->err)){ |
676 |
|
if(fprintf(stream, " ]") < 0){ |
677 |
|
perror("print_val"); |
678 |
|
env->err= 5; |
679 |
|
} |
680 |
|
} |
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, NULL); |
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, NULL); |
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, NULL); |
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 |
} |
} |
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 |
} |
} |
1284 |
myenv.err=0; |
myenv.err=0; |
1285 |
} |
} |
1286 |
sx_72656164(&myenv); /* "read" */ |
sx_72656164(&myenv); /* "read" */ |
1287 |
if (myenv.err==4) { /* EOF */ |
if (myenv.err) { /* EOF or other error */ |
1288 |
myenv.err=0; |
myenv.err=0; |
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); if(myenv.err) continue; |
|
toss(&myenv); /* No error check in main */ |
|
1294 |
eval(&myenv); |
eval(&myenv); |
1295 |
|
} else { |
1296 |
|
gc_maybe(&myenv); |
1297 |
} |
} |
|
gc_maybe(&myenv); |
|
1298 |
} |
} |
1299 |
quit(&myenv); |
quit(&myenv); |
1300 |
return EXIT_FAILURE; |
return EXIT_FAILURE; |
1531 |
if(old_value==NULL) |
if(old_value==NULL) |
1532 |
return NULL; |
return NULL; |
1533 |
|
|
|
protect(old_value); |
|
1534 |
new_value= new_val(env); |
new_value= new_val(env); |
1535 |
new_value->type= old_value->type; |
new_value->type= old_value->type; |
1536 |
|
|
1540 |
case func: |
case func: |
1541 |
case symb: |
case symb: |
1542 |
case empty: |
case empty: |
1543 |
|
case port: |
1544 |
new_value->content= old_value->content; |
new_value->content= old_value->content; |
1545 |
break; |
break; |
1546 |
case string: |
case string: |
1558 |
break; |
break; |
1559 |
} |
} |
1560 |
|
|
|
unprotect(old_value); |
|
|
|
|
1561 |
return new_value; |
return new_value; |
1562 |
} |
} |
1563 |
|
|
1639 |
eval(env); |
eval(env); |
1640 |
} |
} |
1641 |
|
|
1642 |
|
/* "else" */ |
1643 |
extern void sx_656c7365(environment *env) |
extern void sx_656c7365(environment *env) |
1644 |
{ |
{ |
1645 |
if(env->head->type==empty || CDR(env->head)->type==empty |
if(env->head->type==empty || CDR(env->head)->type==empty |
1886 |
/* Read a string */ |
/* Read a string */ |
1887 |
extern void readline(environment *env) |
extern void readline(environment *env) |
1888 |
{ |
{ |
1889 |
|
readlinestream(env, env->inputstream); |
1890 |
|
} |
1891 |
|
|
1892 |
|
/* Read a string from a port */ |
1893 |
|
extern void readlineport(environment *env) |
1894 |
|
{ |
1895 |
|
FILE *stream; |
1896 |
|
|
1897 |
|
if(env->head->type==empty) { |
1898 |
|
printerr("Too Few Arguments"); |
1899 |
|
env->err= 1; |
1900 |
|
return; |
1901 |
|
} |
1902 |
|
|
1903 |
|
if(CAR(env->head)->type!=port) { |
1904 |
|
printerr("Bad Argument Type"); |
1905 |
|
env->err= 2; |
1906 |
|
return; |
1907 |
|
} |
1908 |
|
|
1909 |
|
stream=CAR(env->head)->content.p; |
1910 |
|
readlinestream(env, stream); if(env->err) return; |
1911 |
|
|
1912 |
|
swap(env); if(env->err) return; |
1913 |
|
toss(env); |
1914 |
|
} |
1915 |
|
|
1916 |
|
/* read a line from a stream; used by readline */ |
1917 |
|
void readlinestream(environment *env, FILE *stream) |
1918 |
|
{ |
1919 |
char in_string[101]; |
char in_string[101]; |
1920 |
|
|
1921 |
if(fgets(in_string, 100, env->inputstream)==NULL) |
if(fgets(in_string, 100, stream)==NULL) { |
1922 |
push_cstring(env, ""); |
push_cstring(env, ""); |
1923 |
else |
if (! feof(stream)){ |
1924 |
|
perror("readline"); |
1925 |
|
env->err= 5; |
1926 |
|
} |
1927 |
|
} else { |
1928 |
push_cstring(env, in_string); |
push_cstring(env, in_string); |
1929 |
|
} |
1930 |
} |
} |
1931 |
|
|
1932 |
/* "read"; Read a value and place on stack */ |
/* "read"; Read a value and place on stack */ |
1933 |
extern void sx_72656164(environment *env) |
extern void sx_72656164(environment *env) |
1934 |
{ |
{ |
1935 |
|
readstream(env, env->inputstream); |
1936 |
|
} |
1937 |
|
|
1938 |
|
/* "readport"; Read a value from a port and place on stack */ |
1939 |
|
extern void readport(environment *env) |
1940 |
|
{ |
1941 |
|
FILE *stream; |
1942 |
|
|
1943 |
|
if(env->head->type==empty) { |
1944 |
|
printerr("Too Few Arguments"); |
1945 |
|
env->err= 1; |
1946 |
|
return; |
1947 |
|
} |
1948 |
|
|
1949 |
|
if(CAR(env->head)->type!=port) { |
1950 |
|
printerr("Bad Argument Type"); |
1951 |
|
env->err= 2; |
1952 |
|
return; |
1953 |
|
} |
1954 |
|
|
1955 |
|
stream=CAR(env->head)->content.p; |
1956 |
|
readstream(env, stream); if(env->err) return; |
1957 |
|
|
1958 |
|
swap(env); if(env->err) return; |
1959 |
|
toss(env); |
1960 |
|
} |
1961 |
|
|
1962 |
|
/* read from a stream; used by "read" and "readport" */ |
1963 |
|
void readstream(environment *env, FILE *stream) |
1964 |
|
{ |
1965 |
const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n"; |
const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n"; |
1966 |
const char strform[]= "\"%[^\"]\"%n"; |
const char strform[]= "\"%[^\"]\"%n"; |
1967 |
const char intform[]= "%i%n"; |
const char intform[]= "%i%n"; |
2746 |
toss(env); |
toss(env); |
2747 |
} |
} |
2748 |
|
|
2749 |
|
/* "do" */ |
2750 |
extern void sx_646f(environment *env) |
extern void sx_646f(environment *env) |
2751 |
{ |
{ |
2752 |
swap(env); if(env->err) return; |
swap(env); if(env->err) return; |
2753 |
eval(env); |
eval(env); |
2754 |
} |
} |
2755 |
|
|
2756 |
|
/* "open" */ |
2757 |
|
/* 2: "file" */ |
2758 |
|
/* 1: "r" => 1: #<port 0x47114711> */ |
2759 |
|
extern void sx_6f70656e(environment *env) |
2760 |
|
{ |
2761 |
|
value *new_port; |
2762 |
|
FILE *stream; |
2763 |
|
|
2764 |
|
if(env->head->type == empty || CDR(env->head)->type == empty) { |
2765 |
|
printerr("Too Few Arguments"); |
2766 |
|
env->err=1; |
2767 |
|
return; |
2768 |
|
} |
2769 |
|
|
2770 |
|
if(CAR(env->head)->type != string |
2771 |
|
|| CAR(CDR(env->head))->type != string) { |
2772 |
|
printerr("Bad Argument Type"); |
2773 |
|
env->err= 2; |
2774 |
|
return; |
2775 |
|
} |
2776 |
|
|
2777 |
|
stream=fopen(CAR(CDR(env->head))->content.ptr, |
2778 |
|
CAR(env->head)->content.ptr); |
2779 |
|
|
2780 |
|
if(stream == NULL) { |
2781 |
|
perror("open"); |
2782 |
|
env->err= 5; |
2783 |
|
return; |
2784 |
|
} |
2785 |
|
|
2786 |
|
new_port=new_val(env); |
2787 |
|
new_port->type=port; |
2788 |
|
new_port->content.p=stream; |
2789 |
|
|
2790 |
|
push_val(env, new_port); |
2791 |
|
|
2792 |
|
swap(env); if(env->err) return; |
2793 |
|
toss(env); if(env->err) return; |
2794 |
|
swap(env); if(env->err) return; |
2795 |
|
toss(env); |
2796 |
|
} |
2797 |
|
|
2798 |
|
|
2799 |
|
/* "close" */ |
2800 |
|
extern void sx_636c6f7365(environment *env) |
2801 |
|
{ |
2802 |
|
int ret; |
2803 |
|
|
2804 |
|
if(env->head->type == empty) { |
2805 |
|
printerr("Too Few Arguments"); |
2806 |
|
env->err=1; |
2807 |
|
return; |
2808 |
|
} |
2809 |
|
|
2810 |
|
if(CAR(env->head)->type != port) { |
2811 |
|
printerr("Bad Argument Type"); |
2812 |
|
env->err= 2; |
2813 |
|
return; |
2814 |
|
} |
2815 |
|
|
2816 |
|
ret= fclose(CAR(env->head)->content.p); |
2817 |
|
|
2818 |
|
if(ret != 0){ |
2819 |
|
perror("close"); |
2820 |
|
env->err= 5; |
2821 |
|
return; |
2822 |
|
} |
2823 |
|
|
2824 |
|
toss(env); |
2825 |
|
} |