--- stack/stack.c 2002/01/07 23:09:01 1.1.1.1 +++ stack/stack.c 2003/08/13 06:12:26 1.134 @@ -1,45 +1,70 @@ -/* printf */ -#include -/* EXIT_SUCCESS */ -#include -/* NULL */ -#include -#include +/* -*- coding: utf-8; -*- */ +/* + stack - an interactive interpreter for a stack-based language + Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + Authors: Mats Alritzson + Teddy Hogeborn +*/ + +#include "stack.h" + +const char* start_message= "Stack version $Revision: 1.134 $\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\ +under certain conditions; type 'copying;' for details.\n"; -#define HASHTBLSIZE 65536 -typedef struct stack_item +/* Initialize a newly created environment */ +void init_env(environment *env) { - enum {value, string, ref, func} type; - union { - void* ptr; - int val; - } content; + int i; - char* id; - struct stack_item* next; -} stackitem; + env->gc_limit= 400000; + env->gc_count= 0; + env->gc_ref= NULL; + env->head= new_val(env); + for(i= 0; isymbols[i]= NULL; + env->err= 0; + env->in_string= NULL; + env->free_string= NULL; + env->inputstream= stdin; + env->interactive= 1; +} -typedef stackitem* hashtbl[HASHTBLSIZE]; -typedef void (*funcp)(stackitem**); -void init_hashtbl(hashtbl out_hash) +void printerr(environment *env, const char* in_string) { - long i; - - for(i= 0; ierrsymb, in_string); } -stackitem** hash(hashtbl in_hashtbl, const char* in_string) + +/* Returns a pointer to a pointer to an element in the hash table. */ +symbol **hash(hashtbl in_hashtbl, const char *in_string) { - long i= 0; - unsigned long out_hash= 0; - char key= 0; - stackitem** position; + int i= 0; + unsigned int out_hash= 0; + char key= '\0'; + symbol **position; - while(1){ + while(1){ /* Hash in_string */ key= in_string[i++]; if(key=='\0') break; @@ -50,203 +75,981 @@ position= &(in_hashtbl[out_hash]); while(1){ - if(*position==NULL) + if(*position==NULL) /* If empty */ return position; - if(strcmp(in_string, (*position)->id)==0) + if(strcmp(in_string, (*position)->id)==0) /* If match */ return position; - position= &((*position)->next); + position= &((*position)->next); /* Try next */ } } -int push(stackitem** stack_head, stackitem* in_item) +/* Create new value */ +value* new_val(environment *env) { - in_item->next= *stack_head; - *stack_head= in_item; - return 1; + value *nval= malloc(sizeof(value)); + stackitem *nitem= malloc(sizeof(stackitem)); + + assert(nval != NULL); + assert(nitem != NULL); + + nval->content.ptr= NULL; + nval->type= empty; + + nitem->item= nval; + nitem->next= env->gc_ref; + + env->gc_ref= nitem; + + env->gc_count += sizeof(value); + nval->gc.flag.mark= 0; + nval->gc.flag.protect= 0; + + return nval; } -int push_val(stackitem** stack_head, int in_val) + +/* Mark values recursively. + Marked values are not collected by the GC. */ +inline void gc_mark(value *val) { - stackitem* new_item= malloc(sizeof(stackitem)); - new_item->content.val= in_val; - new_item->type= value; + if(val==NULL || val->gc.flag.mark) + return; + + val->gc.flag.mark= 1; - push(stack_head, new_item); - return 1; + if(val->type==tcons) { + gc_mark(CAR(val)); + gc_mark(CDR(val)); + } } -int push_cstring(stackitem** stack_head, const char* in_string) + +/* Start GC */ +extern void gc_init(environment *env) { - stackitem* new_item= malloc(sizeof(stackitem)); - new_item->content.ptr= malloc(strlen(in_string)+1); - strcpy(new_item->content.ptr, in_string); - new_item->type= string; + stackitem *new_head= NULL, *titem; + symbol *tsymb; + int i; + + if(env->interactive) + printf("Garbage collecting."); + + /* Mark values on stack */ + gc_mark(env->head); - push(stack_head, new_item); - return 1; + if(env->interactive) + printf("."); + + /* 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; + + while(env->gc_ref!=NULL) { /* Sweep unused values */ + if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */ + + /* Remove content */ + switch(env->gc_ref->item->type){ + case string: + free(env->gc_ref->item->content.string); + break; + case tcons: + free(env->gc_ref->item->content.c); + break; + case port: + case empty: + case unknown: + case integer: + case tfloat: + case func: + case symb: + /* Symbol strings are freed when walking the hash table */ + break; + } + + free(env->gc_ref->item); /* Remove from gc_ref */ + titem= env->gc_ref->next; + free(env->gc_ref); /* Remove value */ + env->gc_ref= titem; + continue; + } + +#ifdef DEBUG + printf("Kept value (%p)", env->gc_ref->item); + if(env->gc_ref->item->gc.flag.mark) + printf(" (marked)"); + if(env->gc_ref->item->gc.flag.protect) + printf(" (protected)"); + switch(env->gc_ref->item->type){ + case integer: + printf(" integer: %d", env->gc_ref->item->content.i); + break; + case func: + printf(" func: %p", env->gc_ref->item->content.func); + break; + case symb: + printf(" symb: %s", env->gc_ref->item->content.sym->id); + break; + case tcons: + printf(" tcons: %p\t%p", CAR(env->gc_ref->item), + CDR(env->gc_ref->item)); + break; + default: + printf(" ", (env->gc_ref->item->type)); + } + printf("\n"); +#endif /* DEBUG */ + + /* Keep values */ + env->gc_count += sizeof(value); + if(env->gc_ref->item->type==string) + env->gc_count += strlen(env->gc_ref->item->content.string)+1; + + 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; + } + + 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 (%d bytes still allocated)\n", env->gc_count); + +} + + +inline void gc_maybe(environment *env) +{ + if(env->gc_count < env->gc_limit) + return; + else + return gc_init(env); } -int mk_hashentry(hashtbl in_hashtbl, stackitem* in_item, const char* id) + +/* Protect values from GC */ +void protect(value *val) { - in_item->id= malloc(strlen(id)+1); + if(val==NULL || val->gc.flag.protect) + return; - strcpy(in_item->id, id); - push(hash(in_hashtbl, id), in_item); + val->gc.flag.protect= 1; - return 1; + if(val->type==tcons) { + protect(CAR(val)); + protect(CDR(val)); + } } -void def_func(hashtbl in_hashtbl, funcp in_func, const char* id) + +/* Unprotect values from GC */ +void unprotect(value *val) { - stackitem* temp= malloc(sizeof(stackitem)); + if(val==NULL || !(val->gc.flag.protect)) + return; - temp->type= func; - temp->content.ptr= in_func; + val->gc.flag.protect= 0; - mk_hashentry(in_hashtbl, temp, id); + if(val->type==tcons) { + unprotect(CAR(val)); + unprotect(CDR(val)); + } } -int push_ref(stackitem** stack_head, hashtbl in_hash, const char* in_string) + +/* Push a value onto the stack */ +void push_val(environment *env, value *val) { - void* handle; - void* symbol; + value *new_value= new_val(env); + + new_value->content.c= malloc(sizeof(pair)); + assert(new_value->content.c!=NULL); + env->gc_count += sizeof(pair); + new_value->type= tcons; + CAR(new_value)= val; + CDR(new_value)= env->head; + env->head= new_value; +} + + +/* Push an integer onto the stack */ +void push_int(environment *env, int in_val) +{ + value *new_value= new_val(env); - stackitem* new_item= malloc(sizeof(stackitem)); - new_item->content.ptr= *hash(in_hash, in_string); - new_item->type= ref; + new_value->content.i= in_val; + new_value->type= integer; - if(new_item->content.ptr==NULL) { - handle= dlopen(NULL, RTLD_LAZY); - symbol= dlsym(handle, in_string); - if(dlerror()==NULL) { - def_func(in_hash, symbol, in_string); - new_item->content.ptr= *hash(in_hash, in_string); - new_item->type= ref; - } + 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.string= malloc(length); + assert(new_value != NULL); + env->gc_count += length; + strcpy(new_value->content.string, in_string); + new_value->type= string; + + push_val(env, new_value); +} + + +/* Mangle a symbol name to a valid C identifier name */ +char *mangle_str(const char *old_string) +{ + char validchars[]= "0123456789abcdef"; + char *new_string, *current; + + new_string= malloc((strlen(old_string)*2)+4); + assert(new_string != NULL); + strcpy(new_string, "sx_"); /* Stack eXternal */ + current= new_string+3; + + while(old_string[0] != '\0'){ + current[0]= validchars[(unsigned char)(old_string[0])/16]; + current[1]= validchars[(unsigned char)(old_string[0])%16]; + current+= 2; + old_string++; } + current[0]= '\0'; - push(stack_head, new_item); - return 1; + return new_string; /* The caller must free() it */ } -extern void toss(stackitem** stack_head) + +/* Push a symbol onto the stack. */ +void push_sym(environment *env, const char *in_string) { - stackitem* temp= *stack_head; + value *new_value; /* A new symbol value */ + /* ...which might point to... */ + symbol **new_symbol; /* (if needed) A new actual symbol */ + /* ...which, if possible, will be bound to... */ + value *new_fvalue; /* (if needed) A new function value */ + /* ...which will point to... */ + void *funcptr; /* A function pointer */ + + static void *handle= NULL; /* Dynamic linker handle */ + const char *dlerr; /* Dynamic linker error */ + char *mangled; /* Mangled function name */ + + new_value= new_val(env); + new_fvalue= new_val(env); + + /* The new value is a symbol */ + new_value->type= symb; + + /* Look up the symbol name in the hash table */ + new_symbol= hash(env->symbols, in_string); + new_value->content.sym= *new_symbol; + + if(*new_symbol==NULL) { /* If symbol was undefined */ + + /* Create a new symbol */ + (*new_symbol)= malloc(sizeof(symbol)); + assert((*new_symbol) != NULL); + (*new_symbol)->val= NULL; /* undefined value */ + (*new_symbol)->next= NULL; + (*new_symbol)->id= malloc(strlen(in_string)+1); + assert((*new_symbol)->id != NULL); + strcpy((*new_symbol)->id, in_string); + + /* Intern the new symbol in the hash table */ + new_value->content.sym= *new_symbol; + + /* Try to load the symbol name as an external function, to see if + we should bind the symbol to a new function pointer value */ + if(handle==NULL) /* If no handle */ + handle= dlopen(NULL, RTLD_LAZY); + + mangled= mangle_str(in_string); /* mangle the name */ + funcptr= dlsym(handle, mangled); /* and try to find it */ + + dlerr= dlerror(); + if(dlerr != NULL) { /* If no function was found */ + funcptr= dlsym(handle, in_string); /* Get function pointer */ + dlerr= dlerror(); + } - *stack_head= (*stack_head)->next; - free(temp); + if(dlerr==NULL) { /* If a function was found */ + new_fvalue->type= func; /* The new value is a function pointer */ + new_fvalue->content.func= funcptr; /* Store function pointer */ + (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new + function value */ + } + + free(mangled); + } + + push_val(env, new_value); } -/* print_stack(stack); */ -void print_st(stackitem* stack_head, long counter) -{ - if(stack_head->next != NULL) - print_st(stack_head->next, counter+1); - - if(stack_head->type==value) - printf("%ld: %d\n", counter, (int)stack_head->content.val); - else if(stack_head->type==string) - printf("%ld: \"%s\"\n", counter, (char*)stack_head->content.ptr); - else - printf("%ld: %p\n", counter, stack_head->content.ptr); +/* Print a value */ +void print_val(environment *env, value *val, int noquote, stackitem *stack, + FILE *stream) +{ + stackitem *titem, *tstack; + int depth; + + switch(val->type) { + case empty: + if(fprintf(stream, "[]") < 0){ + perror("print_val"); + env->err= 5; + return; + } + break; + case unknown: + if(fprintf(stream, "UNKNOWN") < 0){ + perror("print_val"); + env->err= 5; + return; + } + break; + case integer: + if(fprintf(stream, "%d", val->content.i) < 0){ + perror("print_val"); + env->err= 5; + return; + } + break; + case tfloat: + if(fprintf(stream, "%f", val->content.f) < 0){ + perror("print_val"); + env->err= 5; + return; + } + break; + case string: + if(noquote){ + if(fprintf(stream, "%s", val->content.string) < 0){ + perror("print_val"); + env->err= 5; + return; + } + } else { /* quote */ + if(fprintf(stream, "\"%s\"", val->content.string) < 0){ + perror("print_val"); + env->err= 5; + return; + } + } + break; + case symb: + if(fprintf(stream, "%s", val->content.sym->id) < 0){ + perror("print_val"); + env->err= 5; + return; + } + break; + case func: + if(fprintf(stream, "#", val->content.func) < 0){ + perror("print_val"); + env->err= 5; + return; + } + break; + case port: + if(fprintf(stream, "#", val->content.p) < 0){ + perror("print_val"); + env->err= 5; + return; + } + break; + case tcons: + if(fprintf(stream, "[ ") < 0){ + perror("print_val"); + env->err= 5; + return; + } + tstack= stack; + + do { + titem=malloc(sizeof(stackitem)); + assert(titem != NULL); + titem->item=val; + titem->next=tstack; + tstack=titem; /* Put it on the stack */ + /* Search a stack of values being printed to see if we are already + printing this value */ + titem=tstack; + depth=0; + + while(titem != NULL && titem->item != CAR(val)){ + titem=titem->next; + depth++; + } + + if(titem != NULL){ /* If we found it on the stack, */ + if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */ + perror("print_val"); + env->err= 5; + free(titem); + return; + } + } else { + print_val(env, CAR(val), noquote, tstack, stream); + } + + val= CDR(val); + switch(val->type){ + case empty: + break; + case tcons: + /* Search a stack of values being printed to see if we are already + printing this value */ + titem=tstack; + depth=0; + + while(titem != NULL && titem->item != val){ + titem=titem->next; + depth++; + } + if(titem != NULL){ /* If we found it on the stack, */ + if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */ + perror("print_val"); + env->err= 5; + goto printval_end; + } + } else { + if(fprintf(stream, " ") < 0){ + perror("print_val"); + env->err= 5; + goto printval_end; + } + } + break; + default: + if(fprintf(stream, " . ") < 0){ /* Improper list */ + perror("print_val"); + env->err= 5; + goto printval_end; + } + print_val(env, val, noquote, tstack, stream); + } + } while(val->type == tcons && titem == NULL); + + printval_end: + + titem=tstack; + while(titem != stack){ + tstack=titem->next; + free(titem); + titem=tstack; + } + + if(! (env->err)){ + if(fprintf(stream, " ]") < 0){ + perror("print_val"); + env->err= 5; + } + } + break; + } } -extern void printstack(stackitem** stack_head) + +/* Swap the two top elements on the stack. */ +extern void swap(environment *env) { - if(*stack_head != NULL) { - print_st(*stack_head, 1); - printf("\n"); + value *temp= env->head; + + switch(check_args(env, unknown, unknown, empty)) { + case 1: + printerr(env, "Too Few Arguments"); + return; + case 2: + printerr(env, "Bad Argument Type"); + return; + default: + break; } + + env->head= CDR(env->head); + CDR(temp)= CDR(env->head); + CDR(env->head)= temp; +} + + +/* Recall a value from a symbol, if bound */ +extern void rcl(environment *env) +{ + value *val; + + switch(check_args(env, symb, empty)) { + case 1: + printerr(env, "Too Few Arguments"); + return; + case 2: + printerr(env, "Bad Argument Type"); + return; + default: + break; + } + + val= CAR(env->head)->content.sym->val; + if(val == NULL){ + printerr(env, "Unbound Variable"); + env->err= 3; + return; + } + push_val(env, val); /* Return the symbol's bound value */ + swap(env); + if(env->err) return; + env->head= CDR(env->head); } -extern void eval(stackitem** stack_head) +/* If the top element is a symbol, determine if it's bound to a + function value, and if it is, toss the symbol and execute the + function. */ +extern void eval(environment *env) { funcp in_func; + value* temp_val; + value* iterator; + + eval_start: + + gc_maybe(env); + + switch(check_args(env, unknown, empty)) { + case 1: + printerr(env, "Too Few Arguments"); + return; + case 2: + printerr(env, "Bad Argument Type"); + return; + default: + break; + } - if((*stack_head)==NULL || (*stack_head)->type!=ref) + switch(CAR(env->head)->type) { + /* if it's a symbol */ + case symb: + env->errsymb= CAR(env->head)->content.sym->id; + rcl(env); /* get its contents */ + if(env->err) return; + if(CAR(env->head)->type!=symb){ /* don't recurse symbols */ + goto eval_start; + } return; - if(((stackitem*)(*stack_head)->content.ptr)->type==func) { - in_func= (funcp)((stackitem*)(*stack_head)->content.ptr)->content.ptr; - toss(stack_head); - (*in_func)(stack_head); + /* If it's a lone function value, run it */ + case func: + in_func= CAR(env->head)->content.func; + env->head= CDR(env->head); + return in_func(env); + + /* If it's a list */ + case tcons: + temp_val= CAR(env->head); + protect(temp_val); + + env->head= CDR(env->head); + iterator= temp_val; + + while(iterator->type != empty) { + push_val(env, CAR(iterator)); + + if(CAR(env->head)->type==symb + && CAR(env->head)->content.sym->id[0]==';') { + env->head= CDR(env->head); + + if(CDR(iterator)->type == empty){ + goto eval_start; + } + eval(env); + if(env->err) return; + } + if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons) + iterator= CDR(iterator); + else { + printerr(env, "Bad Argument Type"); /* Improper list */ + env->err= 2; + return; + } + } + unprotect(temp_val); + return; + + case empty: + env->head= CDR(env->head); + case integer: + case tfloat: + case string: + case port: + case unknown: return; } } -int stack_read(stackitem** stack_head, hashtbl in_hash, char* in_line) + +/* Internal forget function */ +void forget_sym(symbol **hash_entry) { - char *temp, *rest; - int itemp; - size_t inlength= strlen(in_line)+1; - int convert= 0; + symbol *temp; - temp= malloc(inlength); - rest= malloc(inlength); + temp= *hash_entry; + *hash_entry= (*hash_entry)->next; + + free(temp->id); + free(temp); +} - if((convert= sscanf(in_line, "\"%[^\"\n\r]\" %[^\n\r]", temp, rest)) >= 1) - push_cstring(stack_head, temp); - else if((convert= sscanf(in_line, "%d %[^\n\r]", &itemp, rest)) >= 1) - push_val(stack_head, itemp); - else if((convert= sscanf(in_line, "%[^ ;\n\r]%[^\n\r]", temp, rest)) >= 1) - push_ref(stack_head, in_hash, temp); - else if((convert= sscanf(in_line, "%c%[^\n\r]", temp, rest)) >= 1) - if(*temp==';') - eval(stack_head); - free(temp); +int main(int argc, char **argv) +{ + environment myenv; + int c; /* getopt option character */ - if(convert<2) { - free(rest); - return 0; - } - - stack_read(stack_head, in_hash, rest); +#ifdef __linux__ + mtrace(); +#endif + + init_env(&myenv); + + myenv.interactive = isatty(STDIN_FILENO) && isatty(STDOUT_FILENO); + + while ((c = getopt (argc, argv, "i")) != -1) + switch (c) + { + case 'i': + myenv.interactive = 1; + break; + case '?': + fprintf (stderr, + "Unknown option character '\\x%x'.\n", + optopt); + return EX_USAGE; + default: + abort (); + } - free(rest); - return 1; + if (optind < argc) { + myenv.interactive = 0; + myenv.inputstream= fopen(argv[optind], "r"); + if(myenv.inputstream== NULL) { + perror(argv[0]); + exit (EX_NOINPUT); + } + } + + if(myenv.interactive) + puts(start_message); + + while(1) { + if(myenv.in_string==NULL) { + if (myenv.interactive) { + if(myenv.err) { + printf("(error %d)\n", myenv.err); + myenv.err= 0; + } + printf("\n"); + printstack(&myenv); + printf("> "); + } + myenv.err=0; + } + readstream(&myenv, myenv.inputstream); + if (myenv.err) { /* EOF or other error */ + myenv.err=0; + quit(&myenv); + } else if(myenv.head->type!=empty + && CAR(myenv.head)->type==symb + && CAR(myenv.head)->content.sym->id[0] == ';') { + if(myenv.head->type != empty) + myenv.head= CDR(myenv.head); + eval(&myenv); + } else { + gc_maybe(&myenv); + } + } + quit(&myenv); + return EXIT_FAILURE; } -extern void print(stackitem** stack_head) + +/* Return copy of a value */ +value *copy_val(environment *env, value *old_value) { - if((*stack_head)==NULL) + value *new_value; + + if(old_value==NULL) + return NULL; + + new_value= new_val(env); + new_value->type= old_value->type; + + switch(old_value->type){ + case tfloat: + case integer: + case func: + case symb: + case empty: + case unknown: + case port: + new_value->content= old_value->content; + break; + case string: + new_value->content.string= strdup(old_value->content.string); + break; + case tcons: + + new_value->content.c= malloc(sizeof(pair)); + assert(new_value->content.c!=NULL); + env->gc_count += sizeof(pair); + + CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */ + CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */ + break; + } + + return new_value; +} + + +/* read a line from a stream; used by readline */ +void readlinestream(environment *env, FILE *stream) +{ + char in_string[101]; + + if(fgets(in_string, 100, stream)==NULL) { + push_cstring(env, ""); + if (! feof(stream)){ + perror("readline"); + env->err= 5; + } + } else { + push_cstring(env, in_string); + } +} + + +/* Reverse (flip) a list */ +extern void rev(environment *env) +{ + value *old_head, *new_head, *item; + + if(CAR(env->head)->type==empty) + return; /* Don't reverse an empty list */ + + switch(check_args(env, tcons, empty)) { + case 1: + printerr(env, "Too Few Arguments"); + return; + case 2: + printerr(env, "Bad Argument Type"); return; + default: + break; + } - if((*stack_head)->type==value) - printf("%d", (*stack_head)->content.val); - else if((*stack_head)->type==string) - printf("%s", (char*)(*stack_head)->content.ptr); - else - printf("%p", (*stack_head)->content.ptr); + old_head= CAR(env->head); + new_head= new_val(env); + while(old_head->type != empty) { + item= old_head; + old_head= CDR(old_head); + CDR(item)= new_head; + new_head= item; + } + CAR(env->head)= new_head; +} + + +/* Make a list. */ +extern void pack(environment *env) +{ + value *iterator, *temp, *ending; + + ending=new_val(env); + + iterator= env->head; + if(iterator->type == empty + || (CAR(iterator)->type==symb + && CAR(iterator)->content.sym->id[0]=='[')) { + temp= ending; + if(env->head->type != empty) + env->head= CDR(env->head); + } else { + /* Search for first delimiter */ + while(CDR(iterator)->type != empty + && (CAR(CDR(iterator))->type!=symb + || CAR(CDR(iterator))->content.sym->id[0]!='[')) + iterator= CDR(iterator); + + /* Extract list */ + temp= env->head; + env->head= CDR(iterator); + CDR(iterator)= ending; + + if(env->head->type != empty) + env->head= CDR(env->head); + } - toss(stack_head); + /* Push list */ + + push_val(env, temp); + rev(env); } -extern void nl() + +/* read from a stream; used by "read" and "readport" */ +void readstream(environment *env, FILE *stream) { - printf("\n"); + 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; + size_t inlength; + + if(env->in_string==NULL) { + if(depth > 0 && env->interactive) { + printf("]> "); + } + readlinestream(env, env->inputstream); + if(env->err) return; + + if((CAR(env->head)->content.string)[0]=='\0'){ + env->err= 4; /* "" means EOF */ + return; + } + + env->in_string= malloc(strlen(CAR(env->head)->content.string)+1); + assert(env->in_string != NULL); + env->free_string= env->in_string; /* Save the original pointer */ + strcpy(env->in_string, CAR(env->head)->content.string); + env->head= CDR(env->head); + } + + inlength= strlen(env->in_string)+1; + match= malloc(inlength); + assert(match != NULL); + + if(sscanf(env->in_string, blankform, &readlength) != EOF + && readlength != -1) { + ; + } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF + && readlength != -1) { + 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, "\"\"%n", &readlength) != EOF + && readlength != -1) { + push_cstring(env, ""); + } else if(sscanf(env->in_string, strform, match, &readlength) != EOF + && readlength != -1) { + push_cstring(env, match); + } else if(sscanf(env->in_string, symbform, match, &readlength) != EOF + && readlength != -1) { + push_sym(env, match); + } else if(sscanf(env->in_string, ebrackform, &readlength) != EOF + && readlength != -1) { + pack(env); if(env->err) return; + if(depth != 0) depth--; + } else if(sscanf(env->in_string, semicform, &readlength) != EOF + && readlength != -1) { + push_sym(env, ";"); + } else if(sscanf(env->in_string, bbrackform, &readlength) != EOF + && readlength != -1) { + push_sym(env, "["); + depth++; + } else { + free(env->free_string); + env->in_string = env->free_string = NULL; + } + if (env->in_string != NULL) { + env->in_string += readlength; + } + + free(match); + + if(depth) + return readstream(env, env->inputstream); } -int main() + +int check_args(environment *env, ...) { - stackitem* s= NULL; - hashtbl myhash; - char in_string[100]; + va_list ap; + enum type_enum mytype; + + value *iter= env->head; + int errval= 0; + + va_start(ap, env); + while(1) { + mytype= va_arg(ap, enum type_enum); + // fprintf(stderr, "%s\n", env->errsymb); + + if(mytype==empty) + break; + + if(iter->type==empty || iter==NULL) { + errval= 1; + break; + } - init_hashtbl(myhash); + if(mytype==unknown) { + iter=CDR(iter); + continue; + } - printf("okidok\n "); + if(CAR(iter)->type!=mytype) { + errval= 2; + break; + } - while(fgets(in_string, 100, stdin) != NULL) { - stack_read(&s, myhash, in_string); - printf("okidok\n "); + iter= CDR(iter); } + va_end(ap); - return EXIT_SUCCESS; + env->err= errval; + return errval; }