1 |
|
/* -*- coding: utf-8; -*- */ |
2 |
/* |
/* |
3 |
stack - an interactive interpreter for a stack-based language |
stack - an interactive interpreter for a stack-based language |
4 |
Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn |
Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn |
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> |
38 |
#include <unistd.h> |
#include <unistd.h> |
39 |
/* EX_NOINPUT, EX_USAGE */ |
/* EX_NOINPUT, EX_USAGE */ |
40 |
#include <sysexits.h> |
#include <sysexits.h> |
41 |
|
/* assert */ |
42 |
|
#include <assert.h> |
43 |
|
|
44 |
|
#ifdef __linux__ |
45 |
/* mtrace, muntrace */ |
/* mtrace, muntrace */ |
46 |
#include <mcheck.h> |
#include <mcheck.h> |
47 |
/* ioctl */ |
/* ioctl */ |
48 |
#include <sys/ioctl.h> |
#include <sys/ioctl.h> |
49 |
/* KDMKTONE */ |
/* KDMKTONE */ |
50 |
#include <linux/kd.h> |
#include <linux/kd.h> |
51 |
|
#endif /* __linux__ */ |
52 |
|
|
53 |
#include "stack.h" |
#include "stack.h" |
54 |
|
|
61 |
env->gc_count= 0; |
env->gc_count= 0; |
62 |
env->gc_ref= NULL; |
env->gc_ref= NULL; |
63 |
|
|
64 |
env->head= NULL; |
env->head= new_val(env); |
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; |
79 |
/* Discard the top element of the stack. */ |
/* Discard the top element of the stack. */ |
80 |
extern void toss(environment *env) |
extern void toss(environment *env) |
81 |
{ |
{ |
82 |
if(env->head==NULL) { |
if(env->head->type==empty) { |
83 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
84 |
env->err= 1; |
env->err= 1; |
85 |
return; |
return; |
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= empty; |
131 |
|
|
132 |
nitem->item= nval; |
nitem->item= nval; |
133 |
nitem->next= env->gc_ref; |
nitem->next= env->gc_ref; |
168 |
extern void gc_init(environment *env) |
extern void gc_init(environment *env) |
169 |
{ |
{ |
170 |
stackitem *new_head= NULL, *titem; |
stackitem *new_head= NULL, *titem; |
|
cons *iterator; |
|
171 |
symbol *tsymb; |
symbol *tsymb; |
172 |
int i; |
int i; |
173 |
|
|
191 |
if(env->interactive) |
if(env->interactive) |
192 |
printf("."); |
printf("."); |
193 |
|
|
|
|
|
194 |
env->gc_count= 0; |
env->gc_count= 0; |
195 |
|
|
196 |
while(env->gc_ref!=NULL) { /* Sweep unused values */ |
while(env->gc_ref!=NULL) { /* Sweep unused values */ |
197 |
|
|
198 |
if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */ |
if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */ |
199 |
|
|
200 |
if(env->gc_ref->item->type==string) /* Remove content */ |
/* Remove content */ |
201 |
|
switch(env->gc_ref->item->type){ |
202 |
|
case string: |
203 |
free(env->gc_ref->item->content.ptr); |
free(env->gc_ref->item->content.ptr); |
204 |
|
break; |
205 |
|
case tcons: |
206 |
|
free(env->gc_ref->item->content.c); |
207 |
|
break; |
208 |
|
case port: |
209 |
|
case empty: |
210 |
|
case integer: |
211 |
|
case tfloat: |
212 |
|
case func: |
213 |
|
case symb: |
214 |
|
/* Symbol strings are freed when walking the hash table */ |
215 |
|
} |
216 |
|
|
217 |
free(env->gc_ref->item); /* Remove from gc_ref */ |
free(env->gc_ref->item); /* Remove from gc_ref */ |
218 |
titem= env->gc_ref->next; |
titem= env->gc_ref->next; |
219 |
free(env->gc_ref); /* Remove value */ |
free(env->gc_ref); /* Remove value */ |
220 |
env->gc_ref= titem; |
env->gc_ref= titem; |
221 |
continue; |
continue; |
222 |
} |
} |
223 |
|
#ifdef DEBUG |
224 |
|
printf("Kept value (%p)", env->gc_ref->item); |
225 |
|
if(env->gc_ref->item->gc.flag.mark) |
226 |
|
printf(" (marked)"); |
227 |
|
if(env->gc_ref->item->gc.flag.protect) |
228 |
|
printf(" (protected)"); |
229 |
|
switch(env->gc_ref->item->type){ |
230 |
|
case integer: |
231 |
|
printf(" integer: %d", env->gc_ref->item->content.i); |
232 |
|
break; |
233 |
|
case func: |
234 |
|
printf(" func: %p", env->gc_ref->item->content.ptr); |
235 |
|
break; |
236 |
|
case symb: |
237 |
|
printf(" symb: %s", env->gc_ref->item->content.sym->id); |
238 |
|
break; |
239 |
|
case tcons: |
240 |
|
printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car, |
241 |
|
env->gc_ref->item->content.c->cdr); |
242 |
|
break; |
243 |
|
default: |
244 |
|
printf(" <unknown %d>", (env->gc_ref->item->type)); |
245 |
|
} |
246 |
|
printf("\n"); |
247 |
|
#endif /* DEBUG */ |
248 |
|
|
249 |
/* Keep values */ |
/* Keep values */ |
250 |
env->gc_count += sizeof(value); |
env->gc_count += sizeof(value); |
251 |
if(env->gc_ref->item->type==string) |
if(env->gc_ref->item->type==string) |
252 |
env->gc_count += strlen(env->gc_ref->item->content.ptr); |
env->gc_count += strlen(env->gc_ref->item->content.ptr)+1; |
253 |
|
|
254 |
titem= env->gc_ref->next; |
titem= env->gc_ref->next; |
255 |
env->gc_ref->next= new_head; |
env->gc_ref->next= new_head; |
264 |
env->gc_ref= new_head; |
env->gc_ref= new_head; |
265 |
|
|
266 |
if(env->interactive) |
if(env->interactive) |
267 |
printf("done\n"); |
printf("done (%d bytes still allocated)\n", env->gc_count); |
268 |
|
|
269 |
} |
} |
270 |
|
|
301 |
{ |
{ |
302 |
value *new_value= new_val(env); |
value *new_value= new_val(env); |
303 |
|
|
304 |
new_value->content.c= malloc(sizeof(cons)); |
new_value->content.c= malloc(sizeof(pair)); |
305 |
|
assert(new_value->content.c!=NULL); |
306 |
|
env->gc_count += sizeof(pair); |
307 |
new_value->type= tcons; |
new_value->type= tcons; |
308 |
CAR(new_value)= val; |
CAR(new_value)= val; |
309 |
CDR(new_value)= env->head; |
CDR(new_value)= env->head; |
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'){ |
372 |
{ |
{ |
373 |
char *new_string; |
char *new_string; |
374 |
|
|
375 |
if(env->head==NULL) { |
if(env->head->type==empty) { |
376 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
377 |
env->err= 1; |
env->err= 1; |
378 |
return; |
return; |
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 |
{ |
{ |
497 |
int typenum; |
if(env->head->type==empty) { |
|
|
|
|
if(env->head==NULL) { |
|
498 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
499 |
env->err= 1; |
env->err= 1; |
500 |
return; |
return; |
501 |
} |
} |
502 |
|
|
503 |
typenum= CAR(env->head)->type; |
switch(CAR(env->head)->type){ |
504 |
toss(env); |
case empty: |
505 |
switch(typenum){ |
push_sym(env, "empty"); |
506 |
|
break; |
507 |
case integer: |
case integer: |
508 |
push_sym(env, "integer"); |
push_sym(env, "integer"); |
509 |
break; |
break; |
520 |
push_sym(env, "function"); |
push_sym(env, "function"); |
521 |
break; |
break; |
522 |
case tcons: |
case tcons: |
523 |
push_sym(env, "list"); |
push_sym(env, "pair"); |
524 |
|
break; |
525 |
|
case port: |
526 |
|
push_sym(env, "port"); |
527 |
break; |
break; |
528 |
} |
} |
529 |
} |
swap(env); |
530 |
|
if (env->err) return; |
531 |
|
toss(env); |
532 |
|
} |
533 |
|
|
534 |
/* Prints the top element of the stack. */ |
/* Print a value */ |
535 |
void print_h(value *stack_head, int noquote) |
void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream) |
536 |
{ |
{ |
537 |
switch(CAR(stack_head)->type) { |
stackitem *titem, *tstack; |
538 |
|
int depth; |
539 |
|
|
540 |
|
switch(val->type) { |
541 |
|
case empty: |
542 |
|
if(fprintf(stream, "[]") < 0){ |
543 |
|
perror("print_val"); |
544 |
|
env->err= 5; |
545 |
|
return; |
546 |
|
} |
547 |
|
break; |
548 |
case integer: |
case integer: |
549 |
printf("%d", CAR(stack_head)->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", CAR(stack_head)->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*)CAR(stack_head)->content.ptr); |
if(fprintf(stream, "%s", (char*)(val->content.ptr)) < 0){ |
565 |
else |
perror("print_val"); |
566 |
printf("\"%s\"", (char*)CAR(stack_head)->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", ((symbol *)(CAR(stack_head)->content.ptr))->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)(CAR(stack_head)->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 |
/* A list is just a stack, so make stack_head point to it */ |
if(fprintf(stream, "[ ") < 0){ |
600 |
stack_head= CAR(stack_head); |
perror("print_val"); |
601 |
printf("[ "); |
env->err= 5; |
602 |
while(stack_head != NULL) { |
return; |
603 |
print_h(stack_head, noquote); |
} |
604 |
printf(" "); |
tstack= stack; |
605 |
stack_head= CDR(stack_head); |
do { |
606 |
|
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); |
630 |
|
switch(val->type){ |
631 |
|
case empty: |
632 |
|
break; |
633 |
|
case tcons: |
634 |
|
/* 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; |
656 |
|
default: |
657 |
|
if(fprintf(stream, " . ") < 0){ /* Improper list */ |
658 |
|
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 |
} |
} |
|
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==NULL) { |
if(env->head->type==empty) { |
689 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
690 |
env->err= 1; |
env->err= 1; |
691 |
return; |
return; |
692 |
} |
} |
693 |
print_h(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==NULL) { |
if(env->head->type==empty) { |
711 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
712 |
env->err= 1; |
env->err= 1; |
713 |
return; |
return; |
714 |
} |
} |
715 |
print_h(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) != NULL) |
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_h(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. */ |
792 |
extern void printstack(environment *env) |
extern void printstack(environment *env) |
793 |
{ |
{ |
794 |
if(env->head == NULL) { |
if(env->head->type == empty) { |
795 |
printf("Stack Empty\n"); |
printf("Stack Empty\n"); |
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. */ |
804 |
{ |
{ |
805 |
value *temp= env->head; |
value *temp= env->head; |
806 |
|
|
807 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type == empty || CDR(env->head)->type == empty) { |
808 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
809 |
env->err=1; |
env->err=1; |
810 |
return; |
return; |
820 |
{ |
{ |
821 |
value *temp= env->head; |
value *temp= env->head; |
822 |
|
|
823 |
if(env->head==NULL || CDR(env->head)==NULL |
if(env->head->type == empty || CDR(env->head)->type == empty |
824 |
|| CDR(CDR(env->head))==NULL) { |
|| CDR(CDR(env->head))->type == empty) { |
825 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
826 |
env->err= 1; |
env->err= 1; |
827 |
return; |
return; |
837 |
{ |
{ |
838 |
value *val; |
value *val; |
839 |
|
|
840 |
if(env->head==NULL) { |
if(env->head->type==empty) { |
841 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
842 |
env->err= 1; |
env->err= 1; |
843 |
return; |
return; |
849 |
return; |
return; |
850 |
} |
} |
851 |
|
|
852 |
val= ((symbol *)(CAR(env->head)->content.ptr))->val; |
val= CAR(env->head)->content.sym->val; |
853 |
if(val == NULL){ |
if(val == NULL){ |
854 |
printerr("Unbound Variable"); |
printerr("Unbound Variable"); |
855 |
env->err= 3; |
env->err= 3; |
856 |
return; |
return; |
857 |
} |
} |
858 |
protect(val); |
push_val(env, val); /* Return the symbol's bound value */ |
859 |
toss(env); /* toss the symbol */ |
swap(env); |
860 |
|
if(env->err) return; |
861 |
|
toss(env); /* toss the symbol */ |
862 |
if(env->err) return; |
if(env->err) return; |
|
push_val(env, val); /* Return its bound value */ |
|
|
unprotect(val); |
|
863 |
} |
} |
864 |
|
|
865 |
/* If the top element is a symbol, determine if it's bound to a |
/* If the top element is a symbol, determine if it's bound to a |
875 |
|
|
876 |
gc_maybe(env); |
gc_maybe(env); |
877 |
|
|
878 |
if(env->head==NULL) { |
if(env->head->type==empty) { |
879 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
880 |
env->err= 1; |
env->err= 1; |
881 |
return; |
return; |
906 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
907 |
iterator= temp_val; |
iterator= temp_val; |
908 |
|
|
909 |
while(iterator!=NULL) { |
while(iterator->type != empty) { |
910 |
push_val(env, CAR(iterator)); |
push_val(env, CAR(iterator)); |
911 |
|
|
912 |
if(CAR(env->head)->type==symb |
if(CAR(env->head)->type==symb |
913 |
&& (((symbol*)(CAR(env->head)->content.ptr))->id[0]==';')) { |
&& CAR(env->head)->content.sym->id[0]==';') { |
914 |
toss(env); |
toss(env); |
915 |
if(env->err) return; |
if(env->err) return; |
916 |
|
|
917 |
if(CDR(iterator)==NULL){ |
if(CDR(iterator)->type == empty){ |
918 |
goto eval_start; |
goto eval_start; |
919 |
} |
} |
920 |
eval(env); |
eval(env); |
921 |
if(env->err) return; |
if(env->err) return; |
922 |
} |
} |
923 |
if (CDR(iterator)->type == tcons) |
if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons) |
924 |
iterator= CDR(iterator); |
iterator= CDR(iterator); |
925 |
else { |
else { |
926 |
printerr("Bad Argument Type"); /* Improper list */ |
printerr("Bad Argument Type"); /* Improper list */ |
931 |
unprotect(temp_val); |
unprotect(temp_val); |
932 |
return; |
return; |
933 |
|
|
934 |
default: |
case empty: |
935 |
|
toss(env); |
936 |
|
case integer: |
937 |
|
case tfloat: |
938 |
|
case string: |
939 |
|
case port: |
940 |
return; |
return; |
941 |
} |
} |
942 |
} |
} |
946 |
{ |
{ |
947 |
value *old_head, *new_head, *item; |
value *old_head, *new_head, *item; |
948 |
|
|
949 |
if(env->head==NULL) { |
if(env->head->type==empty) { |
950 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
951 |
env->err= 1; |
env->err= 1; |
952 |
return; |
return; |
953 |
} |
} |
954 |
|
|
955 |
|
if(CAR(env->head)->type==empty) |
956 |
|
return; /* Don't reverse an empty list */ |
957 |
|
|
958 |
if(CAR(env->head)->type!=tcons) { |
if(CAR(env->head)->type!=tcons) { |
959 |
printerr("Bad Argument Type"); |
printerr("Bad Argument Type"); |
960 |
env->err= 2; |
env->err= 2; |
962 |
} |
} |
963 |
|
|
964 |
old_head= CAR(env->head); |
old_head= CAR(env->head); |
965 |
new_head= NULL; |
new_head= new_val(env); |
966 |
while(old_head!=NULL) { |
while(old_head->type != empty) { |
967 |
item= old_head; |
item= old_head; |
968 |
old_head= CDR(old_head); |
old_head= CDR(old_head); |
969 |
CDR(item)= new_head; |
CDR(item)= new_head; |
975 |
/* Make a list. */ |
/* Make a list. */ |
976 |
extern void pack(environment *env) |
extern void pack(environment *env) |
977 |
{ |
{ |
978 |
value *iterator, *temp; |
value *iterator, *temp, *ending; |
979 |
|
|
980 |
|
ending=new_val(env); |
981 |
|
|
982 |
iterator= env->head; |
iterator= env->head; |
983 |
if(iterator==NULL |
if(iterator->type == empty |
984 |
|| (CAR(iterator)->type==symb |
|| (CAR(iterator)->type==symb |
985 |
&& ((symbol*)(CAR(iterator)->content.ptr))->id[0]=='[')) { |
&& CAR(iterator)->content.sym->id[0]=='[')) { |
986 |
temp= NULL; |
temp= ending; |
987 |
toss(env); |
toss(env); |
988 |
} else { |
} else { |
989 |
/* Search for first delimiter */ |
/* Search for first delimiter */ |
990 |
while(CDR(iterator)!=NULL |
while(CDR(iterator)->type != empty |
991 |
&& (CAR(CDR(iterator))->type!=symb |
&& (CAR(CDR(iterator))->type!=symb |
992 |
|| ((symbol*)(CAR(CDR(iterator))->content.ptr))->id[0]!='[')) |
|| CAR(CDR(iterator))->content.sym->id[0]!='[')) |
993 |
iterator= CDR(iterator); |
iterator= CDR(iterator); |
994 |
|
|
995 |
/* Extract list */ |
/* Extract list */ |
996 |
temp= env->head; |
temp= env->head; |
997 |
env->head= CDR(iterator); |
env->head= CDR(iterator); |
998 |
CDR(iterator)= NULL; |
CDR(iterator)= ending; |
999 |
|
|
1000 |
if(env->head!=NULL) |
if(env->head->type != empty) |
1001 |
toss(env); |
toss(env); |
1002 |
} |
} |
1003 |
|
|
1013 |
value *temp, *new_head; |
value *temp, *new_head; |
1014 |
|
|
1015 |
/* Is top element a list? */ |
/* Is top element a list? */ |
1016 |
if(env->head==NULL) { |
if(env->head->type==empty) { |
1017 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1018 |
env->err= 1; |
env->err= 1; |
1019 |
return; |
return; |
1036 |
toss(env); |
toss(env); |
1037 |
|
|
1038 |
/* Find the end of the list */ |
/* Find the end of the list */ |
1039 |
while(CDR(temp)->content.ptr != NULL) { |
while(CDR(temp)->type != empty) { |
1040 |
if (CDR(temp)->type == tcons) |
if (CDR(temp)->type == tcons) |
1041 |
temp= CDR(temp); |
temp= CDR(temp); |
1042 |
else { |
else { |
1057 |
{ |
{ |
1058 |
void *left, *right; |
void *left, *right; |
1059 |
|
|
1060 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
1061 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1062 |
env->err= 1; |
env->err= 1; |
1063 |
return; |
return; |
1075 |
{ |
{ |
1076 |
int val; |
int val; |
1077 |
|
|
1078 |
if(env->head==NULL) { |
if(env->head->type==empty) { |
1079 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1080 |
env->err= 1; |
env->err= 1; |
1081 |
return; |
return; |
1106 |
symbol *sym; |
symbol *sym; |
1107 |
|
|
1108 |
/* Needs two values on the stack, the top one must be a symbol */ |
/* Needs two values on the stack, the top one must be a symbol */ |
1109 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
1110 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1111 |
env->err= 1; |
env->err= 1; |
1112 |
return; |
return; |
1145 |
env->gc_limit= 0; |
env->gc_limit= 0; |
1146 |
gc_maybe(env); |
gc_maybe(env); |
1147 |
|
|
1148 |
|
words(env); |
1149 |
|
|
1150 |
if(env->free_string!=NULL) |
if(env->free_string!=NULL) |
1151 |
free(env->free_string); |
free(env->free_string); |
1152 |
|
|
1153 |
|
#ifdef __linux__ |
1154 |
muntrace(); |
muntrace(); |
1155 |
|
#endif |
1156 |
|
|
1157 |
exit(EXIT_SUCCESS); |
exit(EXIT_SUCCESS); |
1158 |
} |
} |
1160 |
/* Clear stack */ |
/* Clear stack */ |
1161 |
extern void clear(environment *env) |
extern void clear(environment *env) |
1162 |
{ |
{ |
1163 |
while(env->head!=NULL) |
while(env->head->type != empty) |
1164 |
toss(env); |
toss(env); |
1165 |
} |
} |
1166 |
|
|
1173 |
for(i= 0; i<HASHTBLSIZE; i++) { |
for(i= 0; i<HASHTBLSIZE; i++) { |
1174 |
temp= env->symbols[i]; |
temp= env->symbols[i]; |
1175 |
while(temp!=NULL) { |
while(temp!=NULL) { |
1176 |
|
#ifdef DEBUG |
1177 |
|
if (temp->val != NULL && temp->val->gc.flag.protect) |
1178 |
|
printf("(protected) "); |
1179 |
|
#endif /* DEBUG */ |
1180 |
printf("%s\n", temp->id); |
printf("%s\n", temp->id); |
1181 |
temp= temp->next; |
temp= temp->next; |
1182 |
} |
} |
1199 |
extern void forget(environment *env) |
extern void forget(environment *env) |
1200 |
{ |
{ |
1201 |
char* sym_id; |
char* sym_id; |
|
value *stack_head= env->head; |
|
1202 |
|
|
1203 |
if(stack_head==NULL) { |
if(env->head->type==empty) { |
1204 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1205 |
env->err= 1; |
env->err= 1; |
1206 |
return; |
return; |
1207 |
} |
} |
1208 |
|
|
1209 |
if(CAR(stack_head)->type!=symb) { |
if(CAR(env->head)->type!=symb) { |
1210 |
printerr("Bad Argument Type"); |
printerr("Bad Argument Type"); |
1211 |
env->err= 2; |
env->err= 2; |
1212 |
return; |
return; |
1213 |
} |
} |
1214 |
|
|
1215 |
sym_id= ((symbol*)(CAR(stack_head)->content.ptr))->id; |
sym_id= CAR(env->head)->content.sym->id; |
1216 |
toss(env); |
toss(env); |
1217 |
|
|
1218 |
return forget_sym(hash(env->symbols, sym_id)); |
return forget_sym(hash(env->symbols, sym_id)); |
1230 |
|
|
1231 |
int c; /* getopt option character */ |
int c; /* getopt option character */ |
1232 |
|
|
1233 |
|
#ifdef __linux__ |
1234 |
mtrace(); |
mtrace(); |
1235 |
|
#endif |
1236 |
|
|
1237 |
init_env(&myenv); |
init_env(&myenv); |
1238 |
|
|
1246 |
break; |
break; |
1247 |
case '?': |
case '?': |
1248 |
fprintf (stderr, |
fprintf (stderr, |
1249 |
"Unknown option character `\\x%x'.\n", |
"Unknown option character '\\x%x'.\n", |
1250 |
optopt); |
optopt); |
1251 |
return EX_USAGE; |
return EX_USAGE; |
1252 |
default: |
default: |
1265 |
if(myenv.interactive) { |
if(myenv.interactive) { |
1266 |
printf("Stack version $Revision$\n\ |
printf("Stack version $Revision$\n\ |
1267 |
Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn\n\ |
Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn\n\ |
1268 |
Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\ |
Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\ |
1269 |
This is free software, and you are welcome to redistribute it\n\ |
This is free software, and you are welcome to redistribute it\n\ |
1270 |
under certain conditions; type `copying;' for details.\n"); |
under certain conditions; type 'copying;' for details.\n"); |
1271 |
} |
} |
1272 |
|
|
1273 |
while(1) { |
while(1) { |
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); |
sx_72656164(&myenv); /* "read" */ |
1287 |
if (myenv.err==4) { |
if (myenv.err) { /* EOF or other error */ |
1288 |
return EXIT_SUCCESS; /* EOF */ |
myenv.err=0; |
1289 |
} else if(myenv.head!=NULL |
quit(&myenv); |
1290 |
|
} else if(myenv.head->type!=empty |
1291 |
&& CAR(myenv.head)->type==symb |
&& CAR(myenv.head)->type==symb |
1292 |
&& ((symbol*)(CAR(myenv.head)->content.ptr))->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; |
1309 |
char* new_string; |
char* new_string; |
1310 |
value *a_val, *b_val; |
value *a_val, *b_val; |
1311 |
|
|
1312 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
1313 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1314 |
env->err= 1; |
env->err= 1; |
1315 |
return; |
return; |
1324 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1325 |
len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1; |
len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1; |
1326 |
new_string= malloc(len); |
new_string= malloc(len); |
1327 |
|
assert(new_string != NULL); |
1328 |
strcpy(new_string, b_val->content.ptr); |
strcpy(new_string, b_val->content.ptr); |
1329 |
strcat(new_string, a_val->content.ptr); |
strcat(new_string, a_val->content.ptr); |
1330 |
push_cstring(env, new_string); |
push_cstring(env, new_string); |
1388 |
int a, b; |
int a, b; |
1389 |
float fa, fb; |
float fa, fb; |
1390 |
|
|
1391 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
1392 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1393 |
env->err=1; |
env->err=1; |
1394 |
return; |
return; |
1448 |
int a, b; |
int a, b; |
1449 |
float fa, fb; |
float fa, fb; |
1450 |
|
|
1451 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
1452 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1453 |
env->err= 1; |
env->err= 1; |
1454 |
return; |
return; |
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); |
|
protect(new_value); |
|
1535 |
new_value->type= old_value->type; |
new_value->type= old_value->type; |
1536 |
|
|
1537 |
switch(old_value->type){ |
switch(old_value->type){ |
1539 |
case integer: |
case integer: |
1540 |
case func: |
case func: |
1541 |
case symb: |
case symb: |
1542 |
|
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: |
1548 |
strdup((char *)(old_value->content.ptr)); |
strdup((char *)(old_value->content.ptr)); |
1549 |
break; |
break; |
1550 |
case tcons: |
case tcons: |
|
new_value= NULL; |
|
1551 |
|
|
1552 |
new_value->content.c= malloc(sizeof(cons)); |
new_value->content.c= malloc(sizeof(pair)); |
1553 |
|
assert(new_value->content.c!=NULL); |
1554 |
|
env->gc_count += sizeof(pair); |
1555 |
|
|
1556 |
CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */ |
CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */ |
1557 |
CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */ |
CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */ |
1558 |
break; |
break; |
1559 |
} |
} |
1560 |
|
|
|
unprotect(old_value); unprotect(new_value); |
|
|
|
|
1561 |
return new_value; |
return new_value; |
1562 |
} |
} |
1563 |
|
|
1564 |
/* "dup"; duplicates an item on the stack */ |
/* "dup"; duplicates an item on the stack */ |
1565 |
extern void sx_647570(environment *env) |
extern void sx_647570(environment *env) |
1566 |
{ |
{ |
1567 |
if(env->head==NULL) { |
if(env->head->type==empty) { |
1568 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1569 |
env->err= 1; |
env->err= 1; |
1570 |
return; |
return; |
1577 |
{ |
{ |
1578 |
int truth; |
int truth; |
1579 |
|
|
1580 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
1581 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1582 |
env->err= 1; |
env->err= 1; |
1583 |
return; |
return; |
1608 |
{ |
{ |
1609 |
int truth; |
int truth; |
1610 |
|
|
1611 |
if(env->head==NULL || CDR(env->head)==NULL |
if(env->head->type==empty || CDR(env->head)->type==empty |
1612 |
|| CDR(CDR(env->head))==NULL) { |
|| CDR(CDR(env->head))->type==empty) { |
1613 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1614 |
env->err= 1; |
env->err= 1; |
1615 |
return; |
return; |
1639 |
eval(env); |
eval(env); |
1640 |
} |
} |
1641 |
|
|
1642 |
|
/* "else" */ |
1643 |
|
extern void sx_656c7365(environment *env) |
1644 |
|
{ |
1645 |
|
if(env->head->type==empty || CDR(env->head)->type==empty |
1646 |
|
|| CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty |
1647 |
|
|| CDR(CDR(CDR(CDR(env->head))))->type==empty) { |
1648 |
|
printerr("Too Few Arguments"); |
1649 |
|
env->err= 1; |
1650 |
|
return; |
1651 |
|
} |
1652 |
|
|
1653 |
|
if(CAR(CDR(env->head))->type!=symb |
1654 |
|
|| strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0 |
1655 |
|
|| CAR(CDR(CDR(CDR(env->head))))->type!=symb |
1656 |
|
|| strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) { |
1657 |
|
printerr("Bad Argument Type"); |
1658 |
|
env->err= 2; |
1659 |
|
return; |
1660 |
|
} |
1661 |
|
|
1662 |
|
swap(env); toss(env); rot(env); toss(env); |
1663 |
|
ifelse(env); |
1664 |
|
} |
1665 |
|
|
1666 |
|
extern void then(environment *env) |
1667 |
|
{ |
1668 |
|
if(env->head->type==empty || CDR(env->head)->type==empty |
1669 |
|
|| CDR(CDR(env->head))->type==empty) { |
1670 |
|
printerr("Too Few Arguments"); |
1671 |
|
env->err= 1; |
1672 |
|
return; |
1673 |
|
} |
1674 |
|
|
1675 |
|
if(CAR(CDR(env->head))->type!=symb |
1676 |
|
|| strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) { |
1677 |
|
printerr("Bad Argument Type"); |
1678 |
|
env->err= 2; |
1679 |
|
return; |
1680 |
|
} |
1681 |
|
|
1682 |
|
swap(env); toss(env); |
1683 |
|
sx_6966(env); |
1684 |
|
} |
1685 |
|
|
1686 |
/* "while" */ |
/* "while" */ |
1687 |
extern void sx_7768696c65(environment *env) |
extern void sx_7768696c65(environment *env) |
1688 |
{ |
{ |
1689 |
int truth; |
int truth; |
1690 |
value *loop, *test; |
value *loop, *test; |
1691 |
|
|
1692 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
1693 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1694 |
env->err= 1; |
env->err= 1; |
1695 |
return; |
return; |
1735 |
value *loop; |
value *loop; |
1736 |
int foo1, foo2; |
int foo1, foo2; |
1737 |
|
|
1738 |
if(env->head==NULL || CDR(env->head)==NULL |
if(env->head->type==empty || CDR(env->head)->type==empty |
1739 |
|| CDR(CDR(env->head))==NULL) { |
|| CDR(CDR(env->head))->type==empty) { |
1740 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1741 |
env->err= 1; |
env->err= 1; |
1742 |
return; |
return; |
1783 |
value *loop, *foo; |
value *loop, *foo; |
1784 |
value *iterator; |
value *iterator; |
1785 |
|
|
1786 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
1787 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1788 |
env->err= 1; |
env->err= 1; |
1789 |
return; |
return; |
1805 |
|
|
1806 |
iterator= foo; |
iterator= foo; |
1807 |
|
|
1808 |
while(iterator!=NULL) { |
while(iterator->type!=empty) { |
1809 |
push_val(env, CAR(iterator)); |
push_val(env, CAR(iterator)); |
1810 |
push_val(env, loop); |
push_val(env, loop); |
1811 |
eval(env); if(env->err) return; |
eval(env); if(env->err) return; |
1812 |
if (CDR(iterator)->type == tcons){ |
if (iterator->type == tcons){ |
1813 |
iterator= CDR(iterator); |
iterator= CDR(iterator); |
1814 |
} else { |
} else { |
1815 |
printerr("Bad Argument Type"); /* Improper list */ |
printerr("Bad Argument Type"); /* Improper list */ |
1824 |
extern void to(environment *env) |
extern void to(environment *env) |
1825 |
{ |
{ |
1826 |
int ending, start, i; |
int ending, start, i; |
1827 |
value *iterator, *temp; |
value *iterator, *temp, *end; |
1828 |
|
|
1829 |
|
end= new_val(env); |
1830 |
|
|
1831 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
1832 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1833 |
env->err= 1; |
env->err= 1; |
1834 |
return; |
return; |
1858 |
|
|
1859 |
iterator= env->head; |
iterator= env->head; |
1860 |
|
|
1861 |
if(iterator==NULL |
if(iterator->type==empty |
1862 |
|| (CAR(iterator)->type==symb |
|| (CAR(iterator)->type==symb |
1863 |
&& ((symbol*)(CAR(iterator)->content.ptr))->id[0]=='[')) { |
&& CAR(iterator)->content.sym->id[0]=='[')) { |
1864 |
temp= NULL; |
temp= end; |
1865 |
toss(env); |
toss(env); |
1866 |
} else { |
} else { |
1867 |
/* Search for first delimiter */ |
/* Search for first delimiter */ |
1868 |
while(CDR(iterator)!=NULL |
while(CDR(iterator)->type!=empty |
1869 |
&& (CAR(CDR(iterator))->type!=symb |
&& (CAR(CDR(iterator))->type!=symb |
1870 |
|| ((symbol*)(CAR(CDR(iterator))->content.ptr))->id[0] |
|| CAR(CDR(iterator))->content.sym->id[0]!='[')) |
|
!='[')) |
|
1871 |
iterator= CDR(iterator); |
iterator= CDR(iterator); |
1872 |
|
|
1873 |
/* Extract list */ |
/* Extract list */ |
1874 |
temp= env->head; |
temp= env->head; |
1875 |
env->head= CDR(iterator); |
env->head= CDR(iterator); |
1876 |
CDR(iterator)= NULL; |
CDR(iterator)= end; |
1877 |
|
|
1878 |
if(env->head!=NULL) |
if(env->head->type!=empty) |
1879 |
toss(env); |
toss(env); |
1880 |
} |
} |
1881 |
|
|
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"; |
1975 |
int count= -1; |
int count= -1; |
1976 |
float ftemp; |
float ftemp; |
1977 |
static int depth= 0; |
static int depth= 0; |
1978 |
char *match, *ctemp; |
char *match; |
1979 |
size_t inlength; |
size_t inlength; |
1980 |
|
|
1981 |
if(env->in_string==NULL) { |
if(env->in_string==NULL) { |
1990 |
} |
} |
1991 |
|
|
1992 |
env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1); |
env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1); |
1993 |
|
assert(env->in_string != NULL); |
1994 |
env->free_string= env->in_string; /* Save the original pointer */ |
env->free_string= env->in_string; /* Save the original pointer */ |
1995 |
strcpy(env->in_string, CAR(env->head)->content.ptr); |
strcpy(env->in_string, CAR(env->head)->content.ptr); |
1996 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1998 |
|
|
1999 |
inlength= strlen(env->in_string)+1; |
inlength= strlen(env->in_string)+1; |
2000 |
match= malloc(inlength); |
match= malloc(inlength); |
2001 |
|
assert(match != NULL); |
2002 |
|
|
2003 |
if(sscanf(env->in_string, blankform, &readlength) != EOF |
if(sscanf(env->in_string, blankform, &readlength) != EOF |
2004 |
&& readlength != -1) { |
&& readlength != -1) { |
2011 |
} else { |
} else { |
2012 |
push_float(env, ftemp); |
push_float(env, ftemp); |
2013 |
} |
} |
2014 |
|
} else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF |
2015 |
|
&& readlength != -1) { |
2016 |
|
push_cstring(env, ""); |
2017 |
} else if(sscanf(env->in_string, strform, match, &readlength) != EOF |
} else if(sscanf(env->in_string, strform, match, &readlength) != EOF |
2018 |
&& readlength != -1) { |
&& readlength != -1) { |
2019 |
push_cstring(env, match); |
push_cstring(env, match); |
2045 |
return sx_72656164(env); |
return sx_72656164(env); |
2046 |
} |
} |
2047 |
|
|
2048 |
|
#ifdef __linux__ |
2049 |
extern void beep(environment *env) |
extern void beep(environment *env) |
2050 |
{ |
{ |
2051 |
int freq, dur, period, ticks; |
int freq, dur, period, ticks; |
2052 |
|
|
2053 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
2054 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
2055 |
env->err= 1; |
env->err= 1; |
2056 |
return; |
return; |
2088 |
abort(); |
abort(); |
2089 |
} |
} |
2090 |
} |
} |
2091 |
|
#endif /* __linux__ */ |
2092 |
|
|
2093 |
/* "wait" */ |
/* "wait" */ |
2094 |
extern void sx_77616974(environment *env) |
extern void sx_77616974(environment *env) |
2095 |
{ |
{ |
2096 |
int dur; |
int dur; |
2097 |
|
|
2098 |
if(env->head==NULL) { |
if(env->head->type==empty) { |
2099 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
2100 |
env->err= 1; |
env->err= 1; |
2101 |
return; |
return; |
2115 |
|
|
2116 |
extern void copying(environment *env) |
extern void copying(environment *env) |
2117 |
{ |
{ |
2118 |
printf("GNU GENERAL PUBLIC LICENSE\n\ |
printf(" GNU GENERAL PUBLIC LICENSE\n\ |
2119 |
Version 2, June 1991\n\ |
Version 2, June 1991\n\ |
2120 |
\n\ |
\n\ |
2121 |
Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\ |
Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\ |
2404 |
int a, b; |
int a, b; |
2405 |
float fa, fb; |
float fa, fb; |
2406 |
|
|
2407 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
2408 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
2409 |
env->err= 1; |
env->err= 1; |
2410 |
return; |
return; |
2464 |
int a, b; |
int a, b; |
2465 |
float fa, fb; |
float fa, fb; |
2466 |
|
|
2467 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
2468 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
2469 |
env->err= 1; |
env->err= 1; |
2470 |
return; |
return; |
2523 |
{ |
{ |
2524 |
int a, b; |
int a, b; |
2525 |
|
|
2526 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
2527 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
2528 |
env->err= 1; |
env->err= 1; |
2529 |
return; |
return; |
2549 |
{ |
{ |
2550 |
int a, b; |
int a, b; |
2551 |
|
|
2552 |
if(env->head==NULL || CDR(env->head)==NULL) { |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
2553 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
2554 |
env->err= 1; |
env->err= 1; |
2555 |
return; |
return; |
2569 |
printerr("Bad Argument Type"); |
printerr("Bad Argument Type"); |
2570 |
env->err= 2; |
env->err= 2; |
2571 |
} |
} |
2572 |
|
|
2573 |
|
extern void setcar(environment *env) |
2574 |
|
{ |
2575 |
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
2576 |
|
printerr("Too Few Arguments"); |
2577 |
|
env->err= 1; |
2578 |
|
return; |
2579 |
|
} |
2580 |
|
|
2581 |
|
if(CDR(env->head)->type!=tcons) { |
2582 |
|
printerr("Bad Argument Type"); |
2583 |
|
env->err= 2; |
2584 |
|
return; |
2585 |
|
} |
2586 |
|
|
2587 |
|
CAR(CAR(CDR(env->head)))=CAR(env->head); |
2588 |
|
toss(env); |
2589 |
|
} |
2590 |
|
|
2591 |
|
extern void setcdr(environment *env) |
2592 |
|
{ |
2593 |
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
2594 |
|
printerr("Too Few Arguments"); |
2595 |
|
env->err= 1; |
2596 |
|
return; |
2597 |
|
} |
2598 |
|
|
2599 |
|
if(CDR(env->head)->type!=tcons) { |
2600 |
|
printerr("Bad Argument Type"); |
2601 |
|
env->err= 2; |
2602 |
|
return; |
2603 |
|
} |
2604 |
|
|
2605 |
|
CDR(CAR(CDR(env->head)))=CAR(env->head); |
2606 |
|
toss(env); |
2607 |
|
} |
2608 |
|
|
2609 |
|
extern void car(environment *env) |
2610 |
|
{ |
2611 |
|
if(env->head->type==empty) { |
2612 |
|
printerr("Too Few Arguments"); |
2613 |
|
env->err= 1; |
2614 |
|
return; |
2615 |
|
} |
2616 |
|
|
2617 |
|
if(CAR(env->head)->type!=tcons) { |
2618 |
|
printerr("Bad Argument Type"); |
2619 |
|
env->err= 2; |
2620 |
|
return; |
2621 |
|
} |
2622 |
|
|
2623 |
|
CAR(env->head)=CAR(CAR(env->head)); |
2624 |
|
} |
2625 |
|
|
2626 |
|
extern void cdr(environment *env) |
2627 |
|
{ |
2628 |
|
if(env->head->type==empty) { |
2629 |
|
printerr("Too Few Arguments"); |
2630 |
|
env->err= 1; |
2631 |
|
return; |
2632 |
|
} |
2633 |
|
|
2634 |
|
if(CAR(env->head)->type!=tcons) { |
2635 |
|
printerr("Bad Argument Type"); |
2636 |
|
env->err= 2; |
2637 |
|
return; |
2638 |
|
} |
2639 |
|
|
2640 |
|
CAR(env->head)=CDR(CAR(env->head)); |
2641 |
|
} |
2642 |
|
|
2643 |
|
extern void cons(environment *env) |
2644 |
|
{ |
2645 |
|
value *val; |
2646 |
|
|
2647 |
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
2648 |
|
printerr("Too Few Arguments"); |
2649 |
|
env->err= 1; |
2650 |
|
return; |
2651 |
|
} |
2652 |
|
|
2653 |
|
val=new_val(env); |
2654 |
|
val->content.c= malloc(sizeof(pair)); |
2655 |
|
assert(val->content.c!=NULL); |
2656 |
|
|
2657 |
|
env->gc_count += sizeof(pair); |
2658 |
|
val->type=tcons; |
2659 |
|
|
2660 |
|
CAR(val)= CAR(CDR(env->head)); |
2661 |
|
CDR(val)= CAR(env->head); |
2662 |
|
|
2663 |
|
push_val(env, val); |
2664 |
|
|
2665 |
|
swap(env); if(env->err) return; |
2666 |
|
toss(env); if(env->err) return; |
2667 |
|
swap(env); if(env->err) return; |
2668 |
|
toss(env); if(env->err) return; |
2669 |
|
} |
2670 |
|
|
2671 |
|
/* 2: 3 => */ |
2672 |
|
/* 1: [ [ 1 . 2 ] [ 3 . 4 ] ] => 1: [ 3 . 4 ] */ |
2673 |
|
extern void assq(environment *env) |
2674 |
|
{ |
2675 |
|
assocgen(env, eq); |
2676 |
|
} |
2677 |
|
|
2678 |
|
|
2679 |
|
/* General assoc function */ |
2680 |
|
void assocgen(environment *env, funcp eqfunc) |
2681 |
|
{ |
2682 |
|
value *key, *item; |
2683 |
|
|
2684 |
|
/* Needs two values on the stack, the top one must be an association |
2685 |
|
list */ |
2686 |
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
2687 |
|
printerr("Too Few Arguments"); |
2688 |
|
env->err= 1; |
2689 |
|
return; |
2690 |
|
} |
2691 |
|
|
2692 |
|
if(CAR(env->head)->type!=tcons) { |
2693 |
|
printerr("Bad Argument Type"); |
2694 |
|
env->err= 2; |
2695 |
|
return; |
2696 |
|
} |
2697 |
|
|
2698 |
|
key=CAR(CDR(env->head)); |
2699 |
|
item=CAR(env->head); |
2700 |
|
|
2701 |
|
while(item->type == tcons){ |
2702 |
|
if(CAR(item)->type != tcons){ |
2703 |
|
printerr("Bad Argument Type"); |
2704 |
|
env->err= 2; |
2705 |
|
return; |
2706 |
|
} |
2707 |
|
push_val(env, key); |
2708 |
|
push_val(env, CAR(CAR(item))); |
2709 |
|
eqfunc(env); if(env->err) return; |
2710 |
|
|
2711 |
|
/* Check the result of 'eqfunc' */ |
2712 |
|
if(env->head->type==empty) { |
2713 |
|
printerr("Too Few Arguments"); |
2714 |
|
env->err= 1; |
2715 |
|
return; |
2716 |
|
} |
2717 |
|
if(CAR(env->head)->type!=integer) { |
2718 |
|
printerr("Bad Argument Type"); |
2719 |
|
env->err= 2; |
2720 |
|
return; |
2721 |
|
} |
2722 |
|
|
2723 |
|
if(CAR(env->head)->content.i){ |
2724 |
|
toss(env); if(env->err) return; |
2725 |
|
break; |
2726 |
|
} |
2727 |
|
toss(env); if(env->err) return; |
2728 |
|
|
2729 |
|
if(item->type!=tcons) { |
2730 |
|
printerr("Bad Argument Type"); |
2731 |
|
env->err= 2; |
2732 |
|
return; |
2733 |
|
} |
2734 |
|
|
2735 |
|
item=CDR(item); |
2736 |
|
} |
2737 |
|
|
2738 |
|
if(item->type == tcons){ /* A match was found */ |
2739 |
|
push_val(env, CAR(item)); |
2740 |
|
} else { |
2741 |
|
push_int(env, 0); |
2742 |
|
} |
2743 |
|
swap(env); if(env->err) return; |
2744 |
|
toss(env); if(env->err) return; |
2745 |
|
swap(env); if(env->err) return; |
2746 |
|
toss(env); |
2747 |
|
} |
2748 |
|
|
2749 |
|
/* "do" */ |
2750 |
|
extern void sx_646f(environment *env) |
2751 |
|
{ |
2752 |
|
swap(env); if(env->err) return; |
2753 |
|
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 |
|
} |