--- stack/stack.c 2002/03/08 06:44:15 1.92 +++ stack/stack.c 2002/03/10 20:08:47 1.102 @@ -48,10 +48,9 @@ { int i; - env->gc_limit= 20; + env->gc_limit= 400000; env->gc_count= 0; env->gc_ref= NULL; - env->gc_protect= NULL; env->head= NULL; for(i= 0; iinteractive= 1; } -void printerr(const char* in_string) { +void printerr(const char* in_string) +{ fprintf(stderr, "Err: %s\n", in_string); } /* Discard the top element of the stack. */ extern void toss(environment *env) { - stackitem *temp= env->head; + cons *temp= env->head; - if((env->head)==NULL) { + if(env->head==NULL) { printerr("Too Few Arguments"); env->err= 1; return; } - env->head= env->head->next; /* Remove the top stack item */ + env->head= env->head->cdr->content.c; /* Remove the top stack item */ free(temp); /* Free the old top stack item */ - - gc_init(env); } /* Returns a pointer to a pointer to an element in the hash table. */ @@ -113,157 +111,189 @@ } } -value* new_val(environment *env) { +/* Create new value */ +value* new_val(environment *env) +{ value *nval= malloc(sizeof(value)); stackitem *nitem= malloc(sizeof(stackitem)); nval->content.ptr= NULL; - protect(env, nval); - - gc_init(env); nitem->item= nval; nitem->next= env->gc_ref; + env->gc_ref= nitem; - env->gc_count++; - unprotect(env); + env->gc_count += sizeof(value); + nval->gc.flag.mark= 0; + nval->gc.flag.protect= 0; return nval; } -void gc_mark(value *val) { - stackitem *iterator; - - if(val==NULL || val->gc_garb==0) +/* Mark values recursively. + Marked values are not collected by the GC. */ +inline void gc_mark(value *val) +{ + if(val==NULL || val->gc.flag.mark) return; - val->gc_garb= 0; + val->gc.flag.mark= 1; - if(val->type==list) { - iterator= val->content.ptr; - - while(iterator!=NULL) { - gc_mark(iterator->item); - iterator= iterator->next; - } + if(val->type==tcons && val->content.c!=NULL) { + gc_mark(val->content.c->car); + gc_mark(val->content.c->cdr); } } -extern void gc_init(environment *env) { - stackitem *new_head= NULL, *titem, *iterator= env->gc_ref; +inline void gc_maybe(environment *env) +{ + if(env->gc_count < env->gc_limit) + return; + else + return gc_init(env); +} + +/* Start GC */ +extern void gc_init(environment *env) +{ + stackitem *new_head= NULL, *titem; + cons *iterator; symbol *tsymb; int i; - if(env->gc_count < env->gc_limit) - return; + if(env->interactive) + printf("Garbage collecting."); - while(iterator!=NULL) { - iterator->item->gc_garb= 1; - iterator= iterator->next; + /* Mark values on stack */ + if(env->head!=NULL) { + gc_mark(env->head->car); + gc_mark(env->head->cdr); } - /* Mark */ - iterator= env->gc_protect; - while(iterator!=NULL) { - gc_mark(iterator->item); - iterator= iterator->next; - } + if(env->interactive) + printf("."); - iterator= env->head; - while(iterator!=NULL) { - gc_mark(iterator->item); - iterator= iterator->next; - } - for(i= 0; isymbols[i]; - while(tsymb!=NULL) { - gc_mark(tsymb->val); - tsymb= tsymb->next; - } - } + /* Mark values in hashtable */ + for(i= 0; isymbols[i]; tsymb!=NULL; tsymb= tsymb->next) + if (tsymb->val != NULL) + gc_mark(tsymb->val); + + + if(env->interactive) + printf("."); + env->gc_count= 0; - /* Sweep */ - while(env->gc_ref!=NULL) { + while(env->gc_ref!=NULL) { /* Sweep unused values */ + + if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */ - if(env->gc_ref->item->gc_garb) { - switch(env->gc_ref->item->type) { - case string: + if(env->gc_ref->item->type==string) /* Remove content */ free(env->gc_ref->item->content.ptr); - break; - case integer: - break; - case list: - while(env->gc_ref->item->content.ptr!=NULL) { - titem= env->gc_ref->item->content.ptr; - env->gc_ref->item->content.ptr= titem->next; - free(titem); - } - break; - default: - break; - } - free(env->gc_ref->item); - titem= env->gc_ref->next; - free(env->gc_ref); - env->gc_ref= titem; - } else { + + free(env->gc_ref->item); /* Remove from gc_ref */ titem= env->gc_ref->next; - env->gc_ref->next= new_head; - new_head= env->gc_ref; + free(env->gc_ref); /* Remove value */ env->gc_ref= titem; - env->gc_count++; - } + continue; + } + + /* Keep values */ + env->gc_count += sizeof(value); + if(env->gc_ref->item->type==string) + env->gc_count += strlen(env->gc_ref->item->content.ptr); + + titem= env->gc_ref->next; + env->gc_ref->next= new_head; + new_head= env->gc_ref; + new_head->item->gc.flag.mark= 0; + env->gc_ref= titem; } - env->gc_limit= env->gc_count*2; + if (env->gc_limit < env->gc_count*2) + env->gc_limit= env->gc_count*2; + env->gc_ref= new_head; + + if(env->interactive) + printf("done\n"); + } -void protect(environment *env, value *val) +/* Protect values from GC */ +void protect(value *val) { - stackitem *new_item= malloc(sizeof(stackitem)); - new_item->item= val; - new_item->next= env->gc_protect; - env->gc_protect= new_item; + if(val==NULL || val->gc.flag.protect) + return; + + val->gc.flag.protect= 1; + + if(val->type==tcons && val->content.c!=NULL) { + protect(val->content.c->car); + protect(val->content.c->cdr); + } } -void unprotect(environment *env) +/* Unprotect values from GC */ +void unprotect(value *val) { - stackitem *temp= env->gc_protect; - env->gc_protect= env->gc_protect->next; - free(temp); + if(val==NULL || !(val->gc.flag.protect)) + return; + + val->gc.flag.protect= 0; + + if(val->type==tcons && val->content.c!=NULL) { + unprotect(val->content.c->car); + unprotect(val->content.c->cdr); + } } /* Push a value onto the stack */ void push_val(environment *env, value *val) { - stackitem *new_item= malloc(sizeof(stackitem)); - new_item->item= val; - new_item->next= env->head; + cons *new_item= malloc(sizeof(cons)); + new_item->car= val; + + new_item->cdr= new_val(env); + new_item->cdr->type= tcons; + new_item->cdr->content.c= env->head; env->head= new_item; } -/* Push an integer onto the stack. */ +/* Push an integer onto the stack */ void push_int(environment *env, int in_val) { value *new_value= new_val(env); - new_value->content.val= in_val; + new_value->content.i= in_val; new_value->type= integer; push_val(env, new_value); } +/* Push a floating point number onto the stack */ +void push_float(environment *env, float in_val) +{ + value *new_value= new_val(env); + + new_value->content.f= in_val; + new_value->type= tfloat; + + push_val(env, new_value); +} + /* Copy a string onto the stack. */ void push_cstring(environment *env, const char *in_string) { value *new_value= new_val(env); + int length= strlen(in_string)+1; - new_value->content.ptr= malloc(strlen(in_string)+1); + new_value->content.ptr= malloc(length); + env->gc_count += length; strcpy(new_value->content.ptr, in_string); new_value->type= string; @@ -271,7 +301,8 @@ } /* Mangle a symbol name to a valid C identifier name */ -char *mangle_str(const char *old_string){ +char *mangle_str(const char *old_string) +{ char validchars[]= "0123456789abcdef"; char *new_string, *current; @@ -289,7 +320,8 @@ return new_string; /* The caller must free() it */ } -extern void mangle(environment *env){ +extern void mangle(environment *env) +{ char *new_string; if((env->head)==NULL) { @@ -298,13 +330,13 @@ return; } - if(env->head->item->type!=string) { + if(env->head->car->type!=string) { printerr("Bad Argument Type"); env->err= 2; return; } - new_string= mangle_str((const char *)(env->head->item->content.ptr)); + new_string= mangle_str((const char *)(env->head->car->content.ptr)); toss(env); if(env->err) return; @@ -328,6 +360,9 @@ char *mangled; /* Mangled function name */ new_value= new_val(env); + protect(new_value); + new_fvalue= new_val(env); + protect(new_fvalue); /* The new value is a symbol */ new_value->type= symb; @@ -355,21 +390,25 @@ mangled= mangle_str(in_string); /* mangle the name */ funcptr= dlsym(handle, mangled); /* and try to find it */ - free(mangled); + dlerr= dlerror(); if(dlerr != NULL) { /* If no function was found */ funcptr= dlsym(handle, in_string); /* Get function pointer */ dlerr= dlerror(); } + if(dlerr==NULL) { /* If a function was found */ - new_fvalue= new_val(env); /* Create a new value */ new_fvalue->type= func; /* The new value is a function pointer */ new_fvalue->content.ptr= funcptr; /* Store function pointer */ (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new function value */ } + + free(mangled); } + push_val(env, new_value); + unprotect(new_value); unprotect(new_fvalue); } /* Print newline. */ @@ -379,7 +418,8 @@ } /* Gets the type of a value */ -extern void type(environment *env){ +extern void type(environment *env) +{ int typenum; if((env->head)==NULL) { @@ -387,12 +427,15 @@ env->err=1; return; } - typenum=env->head->item->type; + typenum=env->head->car->type; toss(env); switch(typenum){ case integer: push_sym(env, "integer"); break; + case tfloat: + push_sym(env, "float"); + break; case string: push_sym(env, "string"); break; @@ -402,46 +445,50 @@ case func: push_sym(env, "function"); break; - case list: + case tcons: push_sym(env, "list"); break; } } /* Prints the top element of the stack. */ -void print_h(stackitem *stack_head, int noquote) +void print_h(cons *stack_head, int noquote) { - switch(stack_head->item->type) { + switch(stack_head->car->type) { case integer: - printf("%d", stack_head->item->content.val); + printf("%d", stack_head->car->content.i); + break; + case tfloat: + printf("%f", stack_head->car->content.f); break; case string: if(noquote) - printf("%s", (char*)stack_head->item->content.ptr); + printf("%s", (char*)stack_head->car->content.ptr); else - printf("\"%s\"", (char*)stack_head->item->content.ptr); + printf("\"%s\"", (char*)stack_head->car->content.ptr); break; case symb: - printf("%s", ((symbol *)(stack_head->item->content.ptr))->id); + printf("%s", ((symbol *)(stack_head->car->content.ptr))->id); break; case func: - printf("#", (funcp)(stack_head->item->content.ptr)); + printf("#", (funcp)(stack_head->car->content.ptr)); break; - case list: + case tcons: /* A list is just a stack, so make stack_head point to it */ - stack_head=(stackitem *)(stack_head->item->content.ptr); + stack_head=(cons*)(stack_head->car->content.ptr); printf("[ "); while(stack_head != NULL) { print_h(stack_head, noquote); printf(" "); - stack_head=stack_head->next; + stack_head= stack_head->cdr->content.c; } printf("]"); break; } } -extern void print_(environment *env) { +extern void print_(environment *env) +{ if(env->head==NULL) { printerr("Too Few Arguments"); env->err=1; @@ -459,7 +506,8 @@ toss(env); } -extern void princ_(environment *env) { +extern void princ_(environment *env) +{ if(env->head==NULL) { printerr("Too Few Arguments"); env->err=1; @@ -477,10 +525,10 @@ } /* Only to be called by function printstack. */ -void print_st(stackitem *stack_head, long counter) +void print_st(cons *stack_head, long counter) { - if(stack_head->next != NULL) - print_st(stack_head->next, counter+1); + if(stack_head->cdr->content.c != NULL) + print_st(stack_head->cdr->content.c, counter+1); printf("%ld: ", counter); print_h(stack_head, 0); nl(); @@ -493,40 +541,41 @@ printf("Stack Empty\n"); return; } + print_st(env->head, 1); } /* Swap the two top elements on the stack. */ extern void swap(environment *env) { - stackitem *temp= env->head; + cons *temp= env->head; - if(env->head==NULL || env->head->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL) { printerr("Too Few Arguments"); env->err=1; return; } - env->head= env->head->next; - temp->next= env->head->next; - env->head->next= temp; + env->head= env->head->cdr->content.c; + temp->cdr->content.c= env->head->cdr->content.c; + env->head->cdr->content.c= temp; } /* Rotate the first three elements on the stack. */ extern void rot(environment *env) { - stackitem *temp= env->head; + cons *temp= env->head; - if(env->head==NULL || env->head->next==NULL - || env->head->next->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL + || env->head->cdr->content.c->cdr->content.c==NULL) { printerr("Too Few Arguments"); env->err=1; return; } - env->head= env->head->next->next; - temp->next->next= env->head->next; - env->head->next= temp; + env->head= env->head->cdr->content.c->cdr->content.c; + temp->cdr->content.c->cdr->content.c= env->head->cdr->content.c; + env->head->cdr->content.c= temp; } /* Recall a value from a symbol, if bound */ @@ -534,29 +583,29 @@ { value *val; - if(env->head == NULL) { + if(env->head==NULL) { printerr("Too Few Arguments"); - env->err=1; + env->err= 1; return; } - if(env->head->item->type!=symb) { + if(env->head->car->type!=symb) { printerr("Bad Argument Type"); - env->err=2; + env->err= 2; return; } - val=((symbol *)(env->head->item->content.ptr))->val; + val= ((symbol *)(env->head->car->content.ptr))->val; if(val == NULL){ printerr("Unbound Variable"); - env->err=3; + env->err= 3; return; } - protect(env, val); + protect(val); toss(env); /* toss the symbol */ if(env->err) return; push_val(env, val); /* Return its bound value */ - unprotect(env); + unprotect(val); } /* If the top element is a symbol, determine if it's bound to a @@ -566,58 +615,60 @@ { funcp in_func; value* temp_val; - stackitem* iterator; + cons* iterator; eval_start: + gc_maybe(env); + if(env->head==NULL) { printerr("Too Few Arguments"); - env->err=1; + env->err= 1; return; } - switch(env->head->item->type) { + switch(env->head->car->type) { /* if it's a symbol */ case symb: rcl(env); /* get its contents */ if(env->err) return; - if(env->head->item->type!=symb){ /* don't recurse symbols */ + if(env->head->car->type!=symb){ /* don't recurse symbols */ goto eval_start; } return; /* If it's a lone function value, run it */ case func: - in_func= (funcp)(env->head->item->content.ptr); + in_func= (funcp)(env->head->car->content.ptr); toss(env); if(env->err) return; return in_func(env); /* If it's a list */ - case list: - temp_val= env->head->item; - protect(env, temp_val); - toss(env); - if(env->err) return; - iterator= (stackitem*)temp_val->content.ptr; - unprotect(env); + case tcons: + temp_val= env->head->car; + protect(temp_val); + + toss(env); if(env->err) return; + iterator= (cons*)temp_val->content.ptr; while(iterator!=NULL) { - push_val(env, iterator->item); + push_val(env, iterator->car); - if(env->head->item->type==symb - && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) { + if(env->head->car->type==symb + && (((symbol*)(env->head->car->content.ptr))->id[0] == ';')) { toss(env); if(env->err) return; - if(iterator->next == NULL){ + if(iterator->cdr->content.c==NULL){ goto eval_start; } eval(env); if(env->err) return; } - iterator= iterator->next; + iterator= iterator->cdr->content.c; } + unprotect(temp_val); return; default: @@ -626,8 +677,9 @@ } /* Reverse (flip) a list */ -extern void rev(environment *env){ - stackitem *old_head, *new_head, *item; +extern void rev(environment *env) +{ + cons *old_head, *new_head, *item; if((env->head)==NULL) { printerr("Too Few Arguments"); @@ -635,65 +687,70 @@ return; } - if(env->head->item->type!=list) { + if(env->head->car->type!=tcons) { printerr("Bad Argument Type"); env->err= 2; return; } - old_head= (stackitem *)(env->head->item->content.ptr); + old_head= (cons*)(env->head->car->content.ptr); new_head= NULL; - while(old_head != NULL){ + while(old_head!=NULL) { item= old_head; - old_head= old_head->next; - item->next= new_head; + old_head= old_head->cdr->content.c; + item->cdr->content.c= new_head; new_head= item; } - env->head->item->content.ptr= new_head; + env->head->car->content.ptr= new_head; } /* Make a list. */ extern void pack(environment *env) { - stackitem *iterator, *temp; + cons *iterator, *temp; value *pack; iterator= env->head; + pack= new_val(env); + protect(pack); if(iterator==NULL - || (iterator->item->type==symb - && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) { + || (iterator->car->type==symb + && ((symbol*)(iterator->car->content.ptr))->id[0]=='[')) { temp= NULL; toss(env); } else { /* Search for first delimiter */ - while(iterator->next!=NULL - && (iterator->next->item->type!=symb - || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='[')) - iterator= iterator->next; + while(iterator->cdr->content.c!=NULL + && (iterator->cdr->content.c->car->type!=symb + || ((symbol*)(iterator->cdr->content.c->car->content.ptr))->id[0] + !='[')) + iterator= iterator->cdr->content.c; /* Extract list */ temp= env->head; - env->head= iterator->next; - iterator->next= NULL; + env->head= iterator->cdr->content.c; + iterator->cdr->content.c= NULL; + + pack->type= tcons; + pack->content.ptr= temp; if(env->head!=NULL) toss(env); } /* Push list */ - pack= new_val(env); - pack->type= list; - pack->content.ptr= temp; push_val(env, pack); rev(env); + + unprotect(pack); } /* Relocate elements of the list on the stack. */ extern void expand(environment *env) { - stackitem *temp, *new_head; + cons *temp, *new_head; /* Is top element a list? */ if(env->head==NULL) { @@ -701,7 +758,7 @@ env->err= 1; return; } - if(env->head->item->type!=list) { + if(env->head->car->type!=tcons) { printerr("Bad Argument Type"); env->err= 2; return; @@ -713,16 +770,16 @@ return; /* The first list element is the new stack head */ - new_head= temp= env->head->item->content.ptr; + new_head= temp= env->head->car->content.ptr; toss(env); /* Find the end of the list */ - while(temp->next!=NULL) - temp= temp->next; + while(temp->cdr->content.c!=NULL) + temp= temp->cdr->content.c; /* Connect the tail of the list with the old stack head */ - temp->next= env->head; + temp->cdr->content.c= env->head; env->head= new_head; /* ...and voila! */ } @@ -731,21 +788,19 @@ extern void eq(environment *env) { void *left, *right; - int result; - if((env->head)==NULL || env->head->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL) { printerr("Too Few Arguments"); env->err= 1; return; } - left= env->head->item->content.ptr; + left= env->head->car->content.ptr; swap(env); - right= env->head->item->content.ptr; - result= (left==right); - + right= env->head->car->content.ptr; toss(env); toss(env); - push_int(env, result); + + push_int(env, left==right); } /* Negates the top element on the stack. */ @@ -753,19 +808,19 @@ { int val; - if((env->head)==NULL) { + if(env->head==NULL) { printerr("Too Few Arguments"); env->err= 1; return; } - if(env->head->item->type!=integer) { + if(env->head->car->type!=integer) { printerr("Bad Argument Type"); env->err= 2; return; } - val= env->head->item->content.val; + val= env->head->car->content.i; toss(env); push_int(env, !val); } @@ -784,23 +839,23 @@ symbol *sym; /* Needs two values on the stack, the top one must be a symbol */ - if(env->head==NULL || env->head->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL) { printerr("Too Few Arguments"); env->err= 1; return; } - if(env->head->item->type!=symb) { + if(env->head->car->type!=symb) { printerr("Bad Argument Type"); env->err= 2; return; } /* long names are a pain */ - sym= env->head->item->content.ptr; + sym= env->head->car->content.ptr; /* Bind the symbol to the value */ - sym->val= env->head->next->item; + sym->val= env->head->cdr->content.c->car; toss(env); toss(env); } @@ -808,7 +863,7 @@ /* Quit stack. */ extern void quit(environment *env) { - long i; + int i; clear(env); @@ -821,7 +876,7 @@ } env->gc_limit= 0; - gc_init(env); + gc_maybe(env); if(env->free_string!=NULL) free(env->free_string); @@ -854,7 +909,8 @@ } /* Internal forget function */ -void forget_sym(symbol **hash_entry) { +void forget_sym(symbol **hash_entry) +{ symbol *temp; temp= *hash_entry; @@ -868,28 +924,29 @@ extern void forget(environment *env) { char* sym_id; - stackitem *stack_head= env->head; + cons *stack_head= env->head; if(stack_head==NULL) { printerr("Too Few Arguments"); - env->err=1; + env->err= 1; return; } - if(stack_head->item->type!=symb) { + if(stack_head->car->type!=symb) { printerr("Bad Argument Type"); - env->err=2; + env->err= 2; return; } - sym_id= ((symbol*)(stack_head->item->content.ptr))->id; + sym_id= ((symbol*)(stack_head->car->content.ptr))->id; toss(env); return forget_sym(hash(env->symbols, sym_id)); } /* Returns the current error number to the stack */ -extern void errn(environment *env){ +extern void errn(environment *env) +{ push_int(env, env->err); } @@ -930,7 +987,7 @@ } if(myenv.interactive) { - printf("Stack version $Revision: 1.92 $\n\ + printf("Stack version $Revision: 1.102 $\n\ Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn\n\ Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\ This is free software, and you are welcome to redistribute it\n\ @@ -953,35 +1010,37 @@ if (myenv.err==4) { return EXIT_SUCCESS; /* EOF */ } else if(myenv.head!=NULL - && myenv.head->item->type==symb - && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') { + && myenv.head->car->type==symb + && ((symbol*)(myenv.head->car->content.ptr))->id[0]==';') { toss(&myenv); /* No error check in main */ eval(&myenv); } - gc_init(&myenv); + gc_maybe(&myenv); } quit(&myenv); return EXIT_FAILURE; } /* "+" */ -extern void sx_2b(environment *env) { +extern void sx_2b(environment *env) +{ int a, b; + float fa, fb; size_t len; char* new_string; value *a_val, *b_val; - if((env->head)==NULL || env->head->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL) { printerr("Too Few Arguments"); env->err= 1; return; } - if(env->head->item->type==string - && env->head->next->item->type==string) { - a_val= env->head->item; - b_val= env->head->next->item; - protect(env, a_val); protect(env, b_val); + if(env->head->car->type==string + && env->head->cdr->content.c->car->type==string) { + a_val= env->head->car; + b_val= env->head->cdr->content.c->car; + protect(a_val); protect(b_val); toss(env); if(env->err) return; toss(env); if(env->err) return; len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1; @@ -989,151 +1048,283 @@ strcpy(new_string, b_val->content.ptr); strcat(new_string, a_val->content.ptr); push_cstring(env, new_string); - unprotect(env); unprotect(env); + unprotect(a_val); unprotect(b_val); free(new_string); + return; } - if(env->head->item->type!=integer - || env->head->next->item->type!=integer) { - printerr("Bad Argument Type"); - env->err=2; + if(env->head->car->type==integer + && env->head->cdr->content.c->car->type==integer) { + a= env->head->car->content.i; + toss(env); if(env->err) return; + b= env->head->car->content.i; + toss(env); if(env->err) return; + push_int(env, b+a); + return; } - a= env->head->item->content.val; - toss(env); if(env->err) return; - - b= env->head->item->content.val; - toss(env); if(env->err) return; - push_int(env, a+b); + + if(env->head->car->type==tfloat + && env->head->cdr->content.c->car->type==tfloat) { + fa= env->head->car->content.f; + toss(env); if(env->err) return; + fb= env->head->car->content.f; + toss(env); if(env->err) return; + push_float(env, fb+fa); + + return; + } + + if(env->head->car->type==tfloat + && env->head->cdr->content.c->car->type==integer) { + fa= env->head->car->content.f; + toss(env); if(env->err) return; + b= env->head->car->content.i; + toss(env); if(env->err) return; + push_float(env, b+fa); + + return; + } + + if(env->head->car->type==integer + && env->head->cdr->content.c->car->type==tfloat) { + a= env->head->car->content.i; + toss(env); if(env->err) return; + fb= env->head->car->content.f; + toss(env); if(env->err) return; + push_float(env, fb+a); + + return; + } + + printerr("Bad Argument Type"); + env->err=2; } /* "-" */ -extern void sx_2d(environment *env) { +extern void sx_2d(environment *env) +{ int a, b; + float fa, fb; - if((env->head)==NULL || env->head->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL) { printerr("Too Few Arguments"); env->err=1; return; } - if(env->head->item->type!=integer - || env->head->next->item->type!=integer) { - printerr("Bad Argument Type"); - env->err=2; + if(env->head->car->type==integer + && env->head->cdr->content.c->car->type==integer) { + a= env->head->car->content.i; + toss(env); if(env->err) return; + b= env->head->car->content.i; + toss(env); if(env->err) return; + push_int(env, b-a); + return; } - a=env->head->item->content.val; - toss(env); if(env->err) return; - b=env->head->item->content.val; - toss(env); if(env->err) return; - push_int(env, b-a); + if(env->head->car->type==tfloat + && env->head->cdr->content.c->car->type==tfloat) { + fa= env->head->car->content.f; + toss(env); if(env->err) return; + fb= env->head->car->content.f; + toss(env); if(env->err) return; + push_float(env, fb-fa); + + return; + } + + if(env->head->car->type==tfloat + && env->head->cdr->content.c->car->type==integer) { + fa= env->head->car->content.f; + toss(env); if(env->err) return; + b= env->head->car->content.i; + toss(env); if(env->err) return; + push_float(env, b-fa); + + return; + } + + if(env->head->car->type==integer + && env->head->cdr->content.c->car->type==tfloat) { + a= env->head->car->content.i; + toss(env); if(env->err) return; + fb= env->head->car->content.f; + toss(env); if(env->err) return; + push_float(env, fb-a); + + return; + } + + printerr("Bad Argument Type"); + env->err=2; } /* ">" */ -extern void sx_3e(environment *env) { +extern void sx_3e(environment *env) +{ int a, b; + float fa, fb; - if((env->head)==NULL || env->head->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL) { printerr("Too Few Arguments"); - env->err=1; + env->err= 1; return; } - if(env->head->item->type!=integer - || env->head->next->item->type!=integer) { - printerr("Bad Argument Type"); - env->err=2; + if(env->head->car->type==integer + && env->head->cdr->content.c->car->type==integer) { + a=env->head->car->content.i; + toss(env); if(env->err) return; + b=env->head->car->content.i; + toss(env); if(env->err) return; + push_int(env, b>a); + return; } - a=env->head->item->content.val; - toss(env); if(env->err) return; - b=env->head->item->content.val; - toss(env); if(env->err) return; - push_int(env, b>a); + if(env->head->car->type==tfloat + && env->head->cdr->content.c->car->type==tfloat) { + fa= env->head->car->content.f; + toss(env); if(env->err) return; + fb= env->head->car->content.f; + toss(env); if(env->err) return; + push_int(env, fb>fa); + + return; + } + + if(env->head->car->type==tfloat + && env->head->cdr->content.c->car->type==integer) { + fa= env->head->car->content.f; + toss(env); if(env->err) return; + b= env->head->car->content.i; + toss(env); if(env->err) return; + push_int(env, b>fa); + + return; + } + + if(env->head->car->type==integer + && env->head->cdr->content.c->car->type==tfloat) { + a= env->head->car->content.i; + toss(env); if(env->err) return; + fb= env->head->car->content.f; + toss(env); if(env->err) return; + push_int(env, fb>a); + + return; + } + + printerr("Bad Argument Type"); + env->err=2; } -/* Return copy of a value */ -value *copy_val(environment *env, value *old_value){ - stackitem *old_item, *new_item, *prev_item; +/* "<" */ +extern void sx_3c(environment *env) +{ + swap(env); if(env->err) return; + sx_3e(env); +} - value *new_value= new_val(env); +/* "<=" */ +extern void sx_3c3d(environment *env) +{ + sx_3e(env); if(env->err) return; + not(env); +} + +/* ">=" */ +extern void sx_3e3d(environment *env) +{ + sx_3c(env); if(env->err) return; + not(env); +} + +/* Return copy of a value */ +value *copy_val(environment *env, value *old_value) +{ + cons *old_item, *new_item, *prev_item; + value *new_value; - protect(env, old_value); + protect(old_value); + new_value= new_val(env); + protect(new_value); new_value->type= old_value->type; switch(old_value->type){ + case tfloat: case integer: - new_value->content.val= old_value->content.val; + case func: + case symb: + new_value->content= old_value->content; break; case string: (char *)(new_value->content.ptr)= strdup((char *)(old_value->content.ptr)); break; - case func: - case symb: - new_value->content.ptr= old_value->content.ptr; - break; - case list: + case tcons: new_value->content.ptr= NULL; prev_item= NULL; - old_item= (stackitem*)(old_value->content.ptr); + old_item= (cons*)(old_value->content.ptr); while(old_item != NULL) { /* While list is not empty */ - new_item= malloc(sizeof(stackitem)); - new_item->item= copy_val(env, old_item->item); /* recurse */ - new_item->next= NULL; + new_item= malloc(sizeof(cons)); + new_item->car= copy_val(env, old_item->car); /* recurse */ + new_item->cdr= new_val(env); + new_item->cdr->type= tcons; + new_item->cdr->content.c= NULL; if(prev_item != NULL) /* If this wasn't the first item */ - prev_item->next= new_item; /* point the previous item to the + prev_item->cdr->content.c= new_item; /* point the previous item to the new item */ else new_value->content.ptr= new_item; - old_item= old_item->next; + old_item= old_item->cdr->content.c; prev_item= new_item; } break; } - unprotect(env); + unprotect(old_value); unprotect(new_value); return new_value; } /* "dup"; duplicates an item on the stack */ -extern void sx_647570(environment *env) { - if((env->head)==NULL) { +extern void sx_647570(environment *env) +{ + if(env->head==NULL) { printerr("Too Few Arguments"); env->err= 1; return; } - push_val(env, copy_val(env, env->head->item)); + push_val(env, copy_val(env, env->head->car)); } /* "if", If-Then */ -extern void sx_6966(environment *env) { - +extern void sx_6966(environment *env) +{ int truth; - if((env->head)==NULL || env->head->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL) { printerr("Too Few Arguments"); env->err= 1; return; } - if(env->head->next->item->type != integer) { + if(env->head->cdr->content.c->car->type != integer) { printerr("Bad Argument Type"); - env->err=2; + env->err= 2; return; } swap(env); if(env->err) return; - truth=env->head->item->content.val; + truth=env->head->car->content.i; toss(env); if(env->err) return; @@ -1145,27 +1336,27 @@ } /* If-Then-Else */ -extern void ifelse(environment *env) { - +extern void ifelse(environment *env) +{ int truth; - if((env->head)==NULL || env->head->next==NULL - || env->head->next->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL + || env->head->cdr->content.c->cdr->content.c==NULL) { printerr("Too Few Arguments"); - env->err=1; + env->err= 1; return; } - if(env->head->next->next->item->type != integer) { + if(env->head->cdr->content.c->cdr->content.c->car->type!=integer) { printerr("Bad Argument Type"); - env->err=2; + env->err= 2; return; } rot(env); if(env->err) return; - truth=env->head->item->content.val; + truth= env->head->car->content.i; toss(env); if(env->err) return; @@ -1181,36 +1372,36 @@ } /* "while" */ -extern void sx_7768696c65(environment *env) { - +extern void sx_7768696c65(environment *env) +{ int truth; value *loop, *test; - if((env->head)==NULL || env->head->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL) { printerr("Too Few Arguments"); - env->err=1; + env->err= 1; return; } - loop= env->head->item; - protect(env, loop); + loop= env->head->car; + protect(loop); toss(env); if(env->err) return; - test= env->head->item; - protect(env, test); + test= env->head->car; + protect(test); toss(env); if(env->err) return; do { push_val(env, test); eval(env); - if(env->head->item->type != integer) { + if(env->head->car->type != integer) { printerr("Bad Argument Type"); env->err= 2; return; } - truth= env->head->item->content.val; + truth= env->head->car->content.i; toss(env); if(env->err) return; if(truth) { @@ -1222,37 +1413,38 @@ } while(truth); - unprotect(env); unprotect(env); + unprotect(loop); unprotect(test); } /* "for"; for-loop */ -extern void sx_666f72(environment *env) { +extern void sx_666f72(environment *env) +{ value *loop; int foo1, foo2; - if(env->head==NULL || env->head->next==NULL - || env->head->next->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL + || env->head->cdr->content.c->cdr->content.c==NULL) { printerr("Too Few Arguments"); env->err= 1; return; } - if(env->head->next->item->type!=integer - || env->head->next->next->item->type!=integer) { + if(env->head->cdr->content.c->car->type!=integer + || env->head->cdr->content.c->cdr->content.c->car->type!=integer) { printerr("Bad Argument Type"); env->err= 2; return; } - loop= env->head->item; - protect(env, loop); + loop= env->head->car; + protect(loop); toss(env); if(env->err) return; - foo2= env->head->item->content.val; + foo2= env->head->car->content.i; toss(env); if(env->err) return; - foo1= env->head->item->content.val; + foo1= env->head->car->content.i; toss(env); if(env->err) return; if(foo1<=foo2) { @@ -1270,72 +1462,72 @@ foo1--; } } - unprotect(env); + unprotect(loop); } /* Variant of for-loop */ -extern void foreach(environment *env) { - +extern void foreach(environment *env) +{ value *loop, *foo; - stackitem *iterator; + cons *iterator; - if((env->head)==NULL || env->head->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL) { printerr("Too Few Arguments"); env->err= 1; return; } - if(env->head->next->item->type != list) { + if(env->head->cdr->content.c->car->type!=tcons) { printerr("Bad Argument Type"); env->err= 2; return; } - loop= env->head->item; - protect(env, loop); + loop= env->head->car; + protect(loop); toss(env); if(env->err) return; - foo= env->head->item; - protect(env, foo); + foo= env->head->car; + protect(foo); toss(env); if(env->err) return; iterator= foo->content.ptr; while(iterator!=NULL) { - push_val(env, iterator->item); + push_val(env, iterator->car); push_val(env, loop); eval(env); if(env->err) return; - iterator= iterator->next; + iterator= iterator->cdr->content.c; } - unprotect(env); unprotect(env); + unprotect(loop); unprotect(foo); } /* "to" */ -extern void to(environment *env) { - int i, start, ending; - stackitem *temp_head; - value *temp_val; - - if((env->head)==NULL || env->head->next==NULL) { +extern void to(environment *env) +{ + int ending, start, i; + cons *iterator, *temp; + value *pack; + + if(env->head==NULL || env->head->cdr->content.c==NULL) { printerr("Too Few Arguments"); - env->err=1; + env->err= 1; return; } - if(env->head->item->type!=integer - || env->head->next->item->type!=integer) { + if(env->head->car->type!=integer + || env->head->cdr->content.c->car->type!=integer) { printerr("Bad Argument Type"); - env->err=2; + env->err= 2; return; } - ending= env->head->item->content.val; + ending= env->head->car->content.i; toss(env); if(env->err) return; - start= env->head->item->content.val; + start= env->head->car->content.i; toss(env); if(env->err) return; - temp_head= env->head; - env->head= NULL; + push_sym(env, "["); if(ending>=start) { for(i= ending; i>=start; i--) @@ -1345,15 +1537,45 @@ push_int(env, i); } - temp_val= new_val(env); - temp_val->content.ptr= env->head; - temp_val->type= list; - env->head= temp_head; - push_val(env, temp_val); + iterator= env->head; + pack= new_val(env); + protect(pack); + + if(iterator==NULL + || (iterator->car->type==symb + && ((symbol*)(iterator->car->content.ptr))->id[0]=='[')) { + temp= NULL; + toss(env); + } else { + /* Search for first delimiter */ + while(iterator->cdr->content.c!=NULL + && (iterator->cdr->content.c->car->type!=symb + || ((symbol*)(iterator->cdr->content.c->car->content.ptr))->id[0] + !='[')) + iterator= iterator->cdr->content.c; + + /* Extract list */ + temp= env->head; + env->head= iterator->cdr->content.c; + iterator->cdr->content.c= NULL; + + pack->type= tcons; + pack->content.ptr= temp; + + if(env->head!=NULL) + toss(env); + } + + /* Push list */ + + push_val(env, pack); + + unprotect(pack); } /* Read a string */ -extern void readline(environment *env) { +extern void readline(environment *env) +{ char in_string[101]; if(fgets(in_string, 100, env->inputstream)==NULL) @@ -1363,18 +1585,22 @@ } /* "read"; Read a value and place on stack */ -extern void sx_72656164(environment *env) { +extern void sx_72656164(environment *env) +{ const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n"; const char strform[]= "\"%[^\"]\"%n"; const char intform[]= "%i%n"; + const char fltform[]= "%f%n"; const char blankform[]= "%*[ \t]%n"; const char ebrackform[]= "]%n"; const char semicform[]= ";%n"; const char bbrackform[]= "[%n"; int itemp, readlength= -1; + int count= -1; + float ftemp; static int depth= 0; - char *match; + char *match, *ctemp; size_t inlength; if(env->in_string==NULL) { @@ -1383,26 +1609,31 @@ } readline(env); if(env->err) return; - if(((char *)(env->head->item->content.ptr))[0]=='\0'){ + if(((char *)(env->head->car->content.ptr))[0]=='\0'){ env->err= 4; /* "" means EOF */ return; } - env->in_string= malloc(strlen(env->head->item->content.ptr)+1); + env->in_string= malloc(strlen(env->head->car->content.ptr)+1); env->free_string= env->in_string; /* Save the original pointer */ - strcpy(env->in_string, env->head->item->content.ptr); + strcpy(env->in_string, env->head->car->content.ptr); toss(env); if(env->err) return; } inlength= strlen(env->in_string)+1; match= malloc(inlength); - if(sscanf(env->in_string, blankform, &readlength)!=EOF + if(sscanf(env->in_string, blankform, &readlength) != EOF && readlength != -1) { ; - } else if(sscanf(env->in_string, intform, &itemp, &readlength) != EOF + } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF && readlength != -1) { - push_int(env, itemp); + if(sscanf(env->in_string, intform, &itemp, &count) != EOF + && count==readlength) { + push_int(env, itemp); + } else { + push_float(env, ftemp); + } } else if(sscanf(env->in_string, strform, match, &readlength) != EOF && readlength != -1) { push_cstring(env, match); @@ -1424,7 +1655,7 @@ free(env->free_string); env->in_string = env->free_string = NULL; } - if ( env->in_string != NULL) { + if (env->in_string != NULL) { env->in_string += readlength; } @@ -1434,73 +1665,74 @@ return sx_72656164(env); } -extern void beep(environment *env) { - +extern void beep(environment *env) +{ int freq, dur, period, ticks; - if((env->head)==NULL || env->head->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL) { printerr("Too Few Arguments"); - env->err=1; + env->err= 1; return; } - if(env->head->item->type!=integer - || env->head->next->item->type!=integer) { + if(env->head->car->type!=integer + || env->head->cdr->content.c->car->type!=integer) { printerr("Bad Argument Type"); - env->err=2; + env->err= 2; return; } - dur=env->head->item->content.val; + dur= env->head->car->content.i; toss(env); - freq=env->head->item->content.val; + freq= env->head->car->content.i; toss(env); - period=1193180/freq; /* convert freq from Hz to period + period= 1193180/freq; /* convert freq from Hz to period length */ - ticks=dur*.001193180; /* convert duration from µseconds to + ticks= dur*.001193180; /* convert duration from µseconds to timer ticks */ /* ticks=dur/1000; */ - /* if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */ + /* if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */ switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){ case 0: usleep(dur); return; case -1: perror("beep"); - env->err=5; + env->err= 5; return; default: abort(); } -}; +} /* "wait" */ -extern void sx_77616974(environment *env) { - +extern void sx_77616974(environment *env) +{ int dur; - if((env->head)==NULL) { + if(env->head==NULL) { printerr("Too Few Arguments"); - env->err=1; + env->err= 1; return; } - if(env->head->item->type!=integer) { + if(env->head->car->type!=integer) { printerr("Bad Argument Type"); - env->err=2; + env->err= 2; return; } - dur=env->head->item->content.val; + dur=env->head->car->content.i; toss(env); usleep(dur); -}; +} -extern void copying(environment *env){ +extern void copying(environment *env) +{ printf("GNU GENERAL PUBLIC LICENSE\n\ Version 2, June 1991\n\ \n\ @@ -1759,7 +1991,8 @@ of promoting the sharing and reuse of software generally.\n"); } -extern void warranty(environment *env){ +extern void warranty(environment *env) +{ printf(" NO WARRANTY\n\ \n\ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\ @@ -1787,50 +2020,120 @@ extern void sx_2a(environment *env) { int a, b; + float fa, fb; - if((env->head)==NULL || env->head->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL) { printerr("Too Few Arguments"); - env->err=1; + env->err= 1; return; } - if(env->head->item->type!=integer - || env->head->next->item->type!=integer) { - printerr("Bad Argument Type"); - env->err=2; + if(env->head->car->type==integer + && env->head->cdr->content.c->car->type==integer) { + a= env->head->car->content.i; + toss(env); if(env->err) return; + b= env->head->car->content.i; + toss(env); if(env->err) return; + push_int(env, b*a); + return; } - a=env->head->item->content.val; - toss(env); if(env->err) return; - b=env->head->item->content.val; - toss(env); if(env->err) return; - push_int(env, b*a); + if(env->head->car->type==tfloat + && env->head->cdr->content.c->car->type==tfloat) { + fa= env->head->car->content.f; + toss(env); if(env->err) return; + fb= env->head->car->content.f; + toss(env); if(env->err) return; + push_float(env, fb*fa); + + return; + } + + if(env->head->car->type==tfloat + && env->head->cdr->content.c->car->type==integer) { + fa= env->head->car->content.f; + toss(env); if(env->err) return; + b= env->head->car->content.i; + toss(env); if(env->err) return; + push_float(env, b*fa); + + return; + } + + if(env->head->car->type==integer + && env->head->cdr->content.c->car->type==tfloat) { + a= env->head->car->content.i; + toss(env); if(env->err) return; + fb= env->head->car->content.f; + toss(env); if(env->err) return; + push_float(env, fb*a); + + return; + } + + printerr("Bad Argument Type"); + env->err= 2; } /* "/" */ extern void sx_2f(environment *env) { int a, b; + float fa, fb; - if((env->head)==NULL || env->head->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL) { printerr("Too Few Arguments"); - env->err=1; + env->err= 1; return; } - if(env->head->item->type!=integer - || env->head->next->item->type!=integer) { - printerr("Bad Argument Type"); - env->err=2; + if(env->head->car->type==integer + && env->head->cdr->content.c->car->type==integer) { + a= env->head->car->content.i; + toss(env); if(env->err) return; + b= env->head->car->content.i; + toss(env); if(env->err) return; + push_float(env, b/a); + return; } - a=env->head->item->content.val; - toss(env); if(env->err) return; - b=env->head->item->content.val; - toss(env); if(env->err) return; - push_int(env, b/a); + if(env->head->car->type==tfloat + && env->head->cdr->content.c->car->type==tfloat) { + fa= env->head->car->content.f; + toss(env); if(env->err) return; + fb= env->head->car->content.f; + toss(env); if(env->err) return; + push_float(env, fb/fa); + + return; + } + + if(env->head->car->type==tfloat + && env->head->cdr->content.c->car->type==integer) { + fa= env->head->car->content.f; + toss(env); if(env->err) return; + b= env->head->car->content.i; + toss(env); if(env->err) return; + push_float(env, b/fa); + + return; + } + + if(env->head->car->type==integer + && env->head->cdr->content.c->car->type==tfloat) { + a= env->head->car->content.i; + toss(env); if(env->err) return; + fb= env->head->car->content.f; + toss(env); if(env->err) return; + push_float(env, fb/a); + + return; + } + + printerr("Bad Argument Type"); + env->err= 2; } /* "mod" */ @@ -1838,22 +2141,49 @@ { int a, b; - if((env->head)==NULL || env->head->next==NULL) { + if(env->head==NULL || env->head->cdr->content.c==NULL) { printerr("Too Few Arguments"); - env->err=1; + env->err= 1; return; } - if(env->head->item->type!=integer - || env->head->next->item->type!=integer) { - printerr("Bad Argument Type"); - env->err=2; + if(env->head->car->type==integer + && env->head->cdr->content.c->car->type==integer) { + a= env->head->car->content.i; + toss(env); if(env->err) return; + b= env->head->car->content.i; + toss(env); if(env->err) return; + push_int(env, b%a); + return; } - a=env->head->item->content.val; - toss(env); if(env->err) return; - b=env->head->item->content.val; - toss(env); if(env->err) return; - push_int(env, b%a); + printerr("Bad Argument Type"); + env->err= 2; +} + +/* "div" */ +extern void sx_646976(environment *env) +{ + int a, b; + + if(env->head==NULL || env->head->cdr->content.c==NULL) { + printerr("Too Few Arguments"); + env->err= 1; + return; + } + + if(env->head->car->type==integer + && env->head->cdr->content.c->car->type==integer) { + a= env->head->car->content.i; + toss(env); if(env->err) return; + b= env->head->car->content.i; + toss(env); if(env->err) return; + push_int(env, (int)b/a); + + return; + } + + printerr("Bad Argument Type"); + env->err= 2; }