37 |
#include <unistd.h> |
#include <unistd.h> |
38 |
/* EX_NOINPUT, EX_USAGE */ |
/* EX_NOINPUT, EX_USAGE */ |
39 |
#include <sysexits.h> |
#include <sysexits.h> |
40 |
|
/* assert */ |
41 |
|
#include <assert.h> |
42 |
|
|
43 |
#ifdef __linux__ |
#ifdef __linux__ |
44 |
/* mtrace, muntrace */ |
/* mtrace, muntrace */ |
123 |
stackitem *nitem= malloc(sizeof(stackitem)); |
stackitem *nitem= malloc(sizeof(stackitem)); |
124 |
|
|
125 |
nval->content.ptr= NULL; |
nval->content.ptr= NULL; |
126 |
|
nval->type= integer; |
127 |
|
|
128 |
nitem->item= nval; |
nitem->item= nval; |
129 |
nitem->next= env->gc_ref; |
nitem->next= env->gc_ref; |
188 |
if(env->interactive) |
if(env->interactive) |
189 |
printf("."); |
printf("."); |
190 |
|
|
|
|
|
191 |
env->gc_count= 0; |
env->gc_count= 0; |
192 |
|
|
193 |
while(env->gc_ref!=NULL) { /* Sweep unused values */ |
while(env->gc_ref!=NULL) { /* Sweep unused values */ |
202 |
free(env->gc_ref); /* Remove value */ |
free(env->gc_ref); /* Remove value */ |
203 |
env->gc_ref= titem; |
env->gc_ref= titem; |
204 |
continue; |
continue; |
205 |
} |
} |
206 |
|
#ifdef DEBUG |
207 |
|
printf("Kept value (%p)", env->gc_ref->item); |
208 |
|
if(env->gc_ref->item->gc.flag.mark) |
209 |
|
printf(" (marked)"); |
210 |
|
if(env->gc_ref->item->gc.flag.protect) |
211 |
|
printf(" (protected)"); |
212 |
|
switch(env->gc_ref->item->type){ |
213 |
|
case integer: |
214 |
|
printf(" integer: %d", env->gc_ref->item->content.i); |
215 |
|
break; |
216 |
|
case func: |
217 |
|
printf(" func: %p", env->gc_ref->item->content.ptr); |
218 |
|
break; |
219 |
|
case symb: |
220 |
|
printf(" symb: %s", env->gc_ref->item->content.sym->id); |
221 |
|
break; |
222 |
|
case tcons: |
223 |
|
printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car, |
224 |
|
env->gc_ref->item->content.c->cdr); |
225 |
|
break; |
226 |
|
default: |
227 |
|
printf(" <unknown %d>", (env->gc_ref->item->type)); |
228 |
|
} |
229 |
|
printf("\n"); |
230 |
|
#endif /* DEBUG */ |
231 |
|
|
232 |
/* Keep values */ |
/* Keep values */ |
233 |
env->gc_count += sizeof(value); |
env->gc_count += sizeof(value); |
247 |
env->gc_ref= new_head; |
env->gc_ref= new_head; |
248 |
|
|
249 |
if(env->interactive) |
if(env->interactive) |
250 |
printf("done\n"); |
printf("done (%d bytes still allocated)\n", env->gc_count); |
251 |
|
|
252 |
} |
} |
253 |
|
|
285 |
value *new_value= new_val(env); |
value *new_value= new_val(env); |
286 |
|
|
287 |
new_value->content.c= malloc(sizeof(cons)); |
new_value->content.c= malloc(sizeof(cons)); |
288 |
|
assert(new_value->content.c!=NULL); |
289 |
new_value->type= tcons; |
new_value->type= tcons; |
290 |
CAR(new_value)= val; |
CAR(new_value)= val; |
291 |
CDR(new_value)= env->head; |
CDR(new_value)= env->head; |
631 |
env->err= 3; |
env->err= 3; |
632 |
return; |
return; |
633 |
} |
} |
634 |
protect(val); |
push_val(env, val); /* Return the symbol's bound value */ |
635 |
toss(env); /* toss the symbol */ |
swap(env); |
636 |
|
if(env->err) return; |
637 |
|
toss(env); /* toss the symbol */ |
638 |
if(env->err) return; |
if(env->err) return; |
|
push_val(env, val); /* Return its bound value */ |
|
|
unprotect(val); |
|
639 |
} |
} |
640 |
|
|
641 |
/* 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 |
696 |
eval(env); |
eval(env); |
697 |
if(env->err) return; |
if(env->err) return; |
698 |
} |
} |
699 |
if (CDR(iterator)->type == tcons) |
if (CDR(iterator)==NULL || CDR(iterator)->type == tcons) |
700 |
iterator= CDR(iterator); |
iterator= CDR(iterator); |
701 |
else { |
else { |
702 |
printerr("Bad Argument Type"); /* Improper list */ |
printerr("Bad Argument Type"); /* Improper list */ |
911 |
env->gc_limit= 0; |
env->gc_limit= 0; |
912 |
gc_maybe(env); |
gc_maybe(env); |
913 |
|
|
914 |
|
words(env); |
915 |
|
|
916 |
if(env->free_string!=NULL) |
if(env->free_string!=NULL) |
917 |
free(env->free_string); |
free(env->free_string); |
918 |
|
|
939 |
for(i= 0; i<HASHTBLSIZE; i++) { |
for(i= 0; i<HASHTBLSIZE; i++) { |
940 |
temp= env->symbols[i]; |
temp= env->symbols[i]; |
941 |
while(temp!=NULL) { |
while(temp!=NULL) { |
942 |
|
#ifdef DEBUG |
943 |
|
if (temp->val != NULL && temp->val->gc.flag.protect) |
944 |
|
printf("(protected) "); |
945 |
|
#endif /* DEBUG */ |
946 |
printf("%s\n", temp->id); |
printf("%s\n", temp->id); |
947 |
temp= temp->next; |
temp= temp->next; |
948 |
} |
} |
1013 |
break; |
break; |
1014 |
case '?': |
case '?': |
1015 |
fprintf (stderr, |
fprintf (stderr, |
1016 |
"Unknown option character `\\x%x'.\n", |
"Unknown option character '\\x%x'.\n", |
1017 |
optopt); |
optopt); |
1018 |
return EX_USAGE; |
return EX_USAGE; |
1019 |
default: |
default: |
1032 |
if(myenv.interactive) { |
if(myenv.interactive) { |
1033 |
printf("Stack version $Revision$\n\ |
printf("Stack version $Revision$\n\ |
1034 |
Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn\n\ |
Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn\n\ |
1035 |
Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\ |
Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\ |
1036 |
This is free software, and you are welcome to redistribute it\n\ |
This is free software, and you are welcome to redistribute it\n\ |
1037 |
under certain conditions; type `copying;' for details.\n"); |
under certain conditions; type 'copying;' for details.\n"); |
1038 |
} |
} |
1039 |
|
|
1040 |
while(1) { |
while(1) { |
1049 |
} |
} |
1050 |
myenv.err=0; |
myenv.err=0; |
1051 |
} |
} |
1052 |
sx_72656164(&myenv); |
sx_72656164(&myenv); /* "read" */ |
1053 |
if (myenv.err==4) { |
if (myenv.err==4) { /* EOF */ |
1054 |
return EXIT_SUCCESS; /* EOF */ |
myenv.err=0; |
1055 |
|
quit(&myenv); |
1056 |
} else if(myenv.head!=NULL |
} else if(myenv.head!=NULL |
1057 |
&& CAR(myenv.head)->type==symb |
&& CAR(myenv.head)->type==symb |
1058 |
&& CAR(myenv.head)->content.sym->id[0] |
&& CAR(myenv.head)->content.sym->id[0] |
1298 |
|
|
1299 |
protect(old_value); |
protect(old_value); |
1300 |
new_value= new_val(env); |
new_value= new_val(env); |
|
protect(new_value); |
|
1301 |
new_value->type= old_value->type; |
new_value->type= old_value->type; |
1302 |
|
|
1303 |
switch(old_value->type){ |
switch(old_value->type){ |
1312 |
strdup((char *)(old_value->content.ptr)); |
strdup((char *)(old_value->content.ptr)); |
1313 |
break; |
break; |
1314 |
case tcons: |
case tcons: |
|
new_value= NULL; |
|
1315 |
|
|
1316 |
new_value->content.c= malloc(sizeof(cons)); |
new_value->content.c= malloc(sizeof(cons)); |
1317 |
|
assert(new_value->content.c!=NULL); |
1318 |
|
|
1319 |
CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */ |
CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */ |
1320 |
CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */ |
CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */ |
1321 |
break; |
break; |
1322 |
} |
} |
1323 |
|
|
1324 |
unprotect(old_value); unprotect(new_value); |
unprotect(old_value); |
1325 |
|
|
1326 |
return new_value; |
return new_value; |
1327 |
} |
} |
1407 |
extern void sx_656c7365(environment *env) |
extern void sx_656c7365(environment *env) |
1408 |
{ |
{ |
1409 |
if(env->head==NULL || CDR(env->head)==NULL |
if(env->head==NULL || CDR(env->head)==NULL |
1410 |
|| CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL) { |
|| CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL |
1411 |
|
|| CDR(CDR(CDR(CDR(env->head))))==NULL) { |
1412 |
|
printerr("Too Few Arguments"); |
1413 |
|
env->err= 1; |
1414 |
|
return; |
1415 |
|
} |
1416 |
|
|
1417 |
|
if(CAR(CDR(env->head))->type!=symb |
1418 |
|
|| strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0 |
1419 |
|
|| CAR(CDR(CDR(CDR(env->head))))->type!=symb |
1420 |
|
|| strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) { |
1421 |
|
printerr("Bad Argument Type"); |
1422 |
|
env->err= 2; |
1423 |
|
return; |
1424 |
|
} |
1425 |
|
|
1426 |
|
swap(env); toss(env); rot(env); toss(env); |
1427 |
|
ifelse(env); |
1428 |
|
} |
1429 |
|
|
1430 |
|
extern void then(environment *env) |
1431 |
|
{ |
1432 |
|
if(env->head==NULL || CDR(env->head)==NULL |
1433 |
|
|| CDR(CDR(env->head))==NULL) { |
1434 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
1435 |
env->err= 1; |
env->err= 1; |
1436 |
return; |
return; |
1444 |
} |
} |
1445 |
|
|
1446 |
swap(env); toss(env); |
swap(env); toss(env); |
1447 |
ifelse(env); |
sx_6966(env); |
1448 |
} |
} |
1449 |
|
|
1450 |
/* "while" */ |
/* "while" */ |