/[cvs]/stack/stack.c
ViewVC logotype

Diff of /stack/stack.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.91 by teddy, Thu Mar 7 03:28:29 2002 UTC revision 1.97 by masse, Sun Mar 10 08:30:43 2002 UTC
# Line 48  void init_env(environment *env) Line 48  void init_env(environment *env)
48  {  {
49    int i;    int i;
50    
51    env->gc_limit= 20;    env->gc_limit= 200;
52    env->gc_count= 0;    env->gc_count= 0;
53    env->gc_ref= NULL;    env->gc_ref= NULL;
54    env->gc_protect= NULL;    env->gc_protect= NULL;
# Line 63  void init_env(environment *env) Line 63  void init_env(environment *env)
63    env->interactive= 1;    env->interactive= 1;
64  }  }
65    
66  void printerr(const char* in_string) {  void printerr(const char* in_string)
67    {
68    fprintf(stderr, "Err: %s\n", in_string);    fprintf(stderr, "Err: %s\n", in_string);
69  }  }
70    
# Line 81  extern void toss(environment *env) Line 82  extern void toss(environment *env)
82    env->head= env->head->next;   /* Remove the top stack item */    env->head= env->head->next;   /* Remove the top stack item */
83    free(temp);                   /* Free the old top stack item */    free(temp);                   /* Free the old top stack item */
84    
85    gc_init(env);    env->gc_limit--;
86  }  }
87    
88  /* Returns a pointer to a pointer to an element in the hash table. */  /* Returns a pointer to a pointer to an element in the hash table. */
# Line 113  symbol **hash(hashtbl in_hashtbl, const Line 114  symbol **hash(hashtbl in_hashtbl, const
114    }    }
115  }  }
116    
117  value* new_val(environment *env) {  /* Create new value */
118    value* new_val(environment *env)
119    {
120    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
121    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
122    
123    nval->content.ptr= NULL;    nval->content.ptr= NULL;
   protect(env, nval);  
   
   gc_init(env);  
124    
125    nitem->item= nval;    nitem->item= nval;
126    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
127    env->gc_ref= nitem;    env->gc_ref= nitem;
128    
129    env->gc_count++;    env->gc_count++;
130    unprotect(env);    nval->gc_garb= 1;
131    
132    return nval;    return nval;
133  }  }
134    
135  void gc_mark(value *val) {  /* Mark values recursively.
136       Marked values are not collected by the GC. */
137    inline void gc_mark(value *val)
138    {
139    stackitem *iterator;    stackitem *iterator;
140    
141    if(val==NULL || val->gc_garb==0)    if(val->gc_garb==0)
142      return;      return;
143    
144    val->gc_garb= 0;    val->gc_garb= 0;
# Line 150  void gc_mark(value *val) { Line 153  void gc_mark(value *val) {
153    }    }
154  }  }
155    
156  extern void gc_init(environment *env) {  inline void gc_maybe(environment *env)
157    stackitem *new_head= NULL, *titem, *iterator= env->gc_ref;  {
   symbol *tsymb;  
   int i;  
   
158    if(env->gc_count < env->gc_limit)    if(env->gc_count < env->gc_limit)
159      return;      return;
160      else
161        return gc_init(env);
162    }
163    
164    while(iterator!=NULL) {  /* Start GC */
165      iterator->item->gc_garb= 1;  extern void gc_init(environment *env)
166      iterator= iterator->next;  {
167    }    stackitem *new_head= NULL, *titem, *iterator;
168      symbol *tsymb;
169      int i;
170    
171    /* Mark */    /* Mark protected values */
172    iterator= env->gc_protect;    iterator= env->gc_protect;
173    while(iterator!=NULL) {    while(iterator!=NULL) {
174      gc_mark(iterator->item);      gc_mark(iterator->item);
175      iterator= iterator->next;      iterator= iterator->next;
176    }    }
177    
178      /* Mark values on stack */
179    iterator= env->head;    iterator= env->head;
180    while(iterator!=NULL) {    while(iterator!=NULL) {
181      gc_mark(iterator->item);      gc_mark(iterator->item);
182      iterator= iterator->next;      iterator= iterator->next;
183    }    }
184    
185      /* Mark values in hashtable */
186    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
187      tsymb= env->symbols[i];      tsymb= env->symbols[i];
188      while(tsymb!=NULL) {      while(tsymb!=NULL) {
189        gc_mark(tsymb->val);        if (tsymb->val != NULL)
190            gc_mark(tsymb->val);
191        tsymb= tsymb->next;        tsymb= tsymb->next;
192      }      }
193    }    }
194    
195    env->gc_count= 0;    env->gc_count= 0;
196    
197    /* Sweep */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
   while(env->gc_ref!=NULL) {  
198    
199      if(env->gc_ref->item->gc_garb) {      if(env->gc_ref->item->gc_garb) {
200        switch(env->gc_ref->item->type) {  
201          switch(env->gc_ref->item->type) { /* Remove content */
202        case string:        case string:
203          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
204          break;          break;
       case integer:  
         break;  
205        case list:        case list:
206          while(env->gc_ref->item->content.ptr!=NULL) {          while(env->gc_ref->item->content.ptr!=NULL) {
207            titem= env->gc_ref->item->content.ptr;            titem= env->gc_ref->item->content.ptr;
208            env->gc_ref->item->content.ptr= titem->next;            env->gc_ref->item->content.ptr= titem->next;
209            free(titem);            free(titem);
210          }          }
         break;  
211        default:        default:
         break;  
212        }        }
213        free(env->gc_ref->item);        free(env->gc_ref->item);  /* Remove from gc_ref */
214        titem= env->gc_ref->next;        titem= env->gc_ref->next;
215        free(env->gc_ref);        free(env->gc_ref);        /* Remove value */
216        env->gc_ref= titem;        env->gc_ref= titem;
217      } else {        continue;
       titem= env->gc_ref->next;  
       env->gc_ref->next= new_head;  
       new_head= env->gc_ref;  
       env->gc_ref= titem;  
       env->gc_count++;  
218      }      }
219        
220        /* Keep values */
221        titem= env->gc_ref->next;
222        env->gc_ref->next= new_head;
223        new_head= env->gc_ref;
224        new_head->item->gc_garb= 1;
225        env->gc_ref= titem;
226        env->gc_count++;
227    }    }
228    
229    env->gc_limit= env->gc_count*2;    env->gc_limit= env->gc_count*2;
230    env->gc_ref= new_head;    env->gc_ref= new_head;
231  }  }
232    
233    /* Protect values from GC */
234  void protect(environment *env, value *val)  void protect(environment *env, value *val)
235  {  {
236    stackitem *new_item= malloc(sizeof(stackitem));    stackitem *new_item= malloc(sizeof(stackitem));
# Line 231  void protect(environment *env, value *va Line 239  void protect(environment *env, value *va
239    env->gc_protect= new_item;    env->gc_protect= new_item;
240  }  }
241    
242    /* Unprotect values from GC */
243  void unprotect(environment *env)  void unprotect(environment *env)
244  {  {
245    stackitem *temp= env->gc_protect;    stackitem *temp= env->gc_protect;
# Line 247  void push_val(environment *env, value *v Line 256  void push_val(environment *env, value *v
256    env->head= new_item;    env->head= new_item;
257  }  }
258    
259  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
260  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
261  {  {
262    value *new_value= new_val(env);    value *new_value= new_val(env);
263        
264    new_value->content.val= in_val;    new_value->content.i= in_val;
265    new_value->type= integer;    new_value->type= integer;
266    
267    push_val(env, new_value);    push_val(env, new_value);
268  }  }
269    
270    /* Push a floating point number onto the stack */
271    void push_float(environment *env, float in_val)
272    {
273      value *new_value= new_val(env);
274    
275      new_value->content.f= in_val;
276      new_value->type= tfloat;
277    
278      push_val(env, new_value);
279    }
280    
281  /* Copy a string onto the stack. */  /* Copy a string onto the stack. */
282  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
283  {  {
# Line 271  void push_cstring(environment *env, cons Line 291  void push_cstring(environment *env, cons
291  }  }
292    
293  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
294  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
295    {
296    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
297    char *new_string, *current;    char *new_string, *current;
298    
# Line 289  char *mangle_str(const char *old_string) Line 310  char *mangle_str(const char *old_string)
310    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
311  }  }
312    
313  extern void mangle(environment *env){  extern void mangle(environment *env)
314    {
315    char *new_string;    char *new_string;
316    
317    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 328  void push_sym(environment *env, const ch Line 350  void push_sym(environment *env, const ch
350    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
351    
352    new_value= new_val(env);    new_value= new_val(env);
353      protect(env, new_value);
354      new_fvalue= new_val(env);
355      protect(env, new_fvalue);
356    
357    /* The new value is a symbol */    /* The new value is a symbol */
358    new_value->type= symb;    new_value->type= symb;
# Line 355  void push_sym(environment *env, const ch Line 380  void push_sym(environment *env, const ch
380    
381      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
382      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
383      free(mangled);  
384      dlerr= dlerror();      dlerr= dlerror();
385      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
386        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
387        dlerr= dlerror();        dlerr= dlerror();
388      }      }
389    
390      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
       new_fvalue= new_val(env); /* Create a new value */  
391        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
392        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
393        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
394                                           function value */                                           function value */
395      }      }
396    
397        free(mangled);
398    }    }
399    
400    push_val(env, new_value);    push_val(env, new_value);
401      unprotect(env); unprotect(env);
402  }  }
403    
404  /* Print newline. */  /* Print newline. */
# Line 379  extern void nl() Line 408  extern void nl()
408  }  }
409    
410  /* Gets the type of a value */  /* Gets the type of a value */
411  extern void type(environment *env){  extern void type(environment *env)
412    {
413    int typenum;    int typenum;
414    
415    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 393  extern void type(environment *env){ Line 423  extern void type(environment *env){
423    case integer:    case integer:
424      push_sym(env, "integer");      push_sym(env, "integer");
425      break;      break;
426      case tfloat:
427        push_sym(env, "float");
428        break;
429    case string:    case string:
430      push_sym(env, "string");      push_sym(env, "string");
431      break;      break;
# Line 413  void print_h(stackitem *stack_head, int Line 446  void print_h(stackitem *stack_head, int
446  {  {
447    switch(stack_head->item->type) {    switch(stack_head->item->type) {
448    case integer:    case integer:
449      printf("%d", stack_head->item->content.val);      printf("%d", stack_head->item->content.i);
450        break;
451      case tfloat:
452        printf("%f", stack_head->item->content.f);
453      break;      break;
454    case string:    case string:
455      if(noquote)      if(noquote)
# Line 441  void print_h(stackitem *stack_head, int Line 477  void print_h(stackitem *stack_head, int
477    }    }
478  }  }
479    
480  extern void print_(environment *env) {  extern void print_(environment *env)
481    {
482    if(env->head==NULL) {    if(env->head==NULL) {
483      printerr("Too Few Arguments");      printerr("Too Few Arguments");
484      env->err=1;      env->err=1;
# Line 459  extern void print(environment *env) Line 496  extern void print(environment *env)
496    toss(env);    toss(env);
497  }  }
498    
499  extern void princ_(environment *env) {  extern void princ_(environment *env)
500    {
501    if(env->head==NULL) {    if(env->head==NULL) {
502      printerr("Too Few Arguments");      printerr("Too Few Arguments");
503      env->err=1;      env->err=1;
# Line 493  extern void printstack(environment *env) Line 531  extern void printstack(environment *env)
531      printf("Stack Empty\n");      printf("Stack Empty\n");
532      return;      return;
533    }    }
534    
535    print_st(env->head, 1);    print_st(env->head, 1);
536  }  }
537    
# Line 570  extern void eval(environment *env) Line 609  extern void eval(environment *env)
609    
610   eval_start:   eval_start:
611    
612      gc_maybe(env);
613    
614    if(env->head==NULL) {    if(env->head==NULL) {
615      printerr("Too Few Arguments");      printerr("Too Few Arguments");
616      env->err=1;      env->err=1;
# Line 597  extern void eval(environment *env) Line 638  extern void eval(environment *env)
638    case list:    case list:
639      temp_val= env->head->item;      temp_val= env->head->item;
640      protect(env, temp_val);      protect(env, temp_val);
641      toss(env);  
642      if(env->err) return;      toss(env); if(env->err) return;
643      iterator= (stackitem*)temp_val->content.ptr;      iterator= (stackitem*)temp_val->content.ptr;
     unprotect(env);  
644            
645      while(iterator!=NULL) {      while(iterator!=NULL) {
646        push_val(env, iterator->item);        push_val(env, iterator->item);
# Line 618  extern void eval(environment *env) Line 658  extern void eval(environment *env)
658        }        }
659        iterator= iterator->next;        iterator= iterator->next;
660      }      }
661        unprotect(env);
662      return;      return;
663    
664    default:    default:
# Line 626  extern void eval(environment *env) Line 667  extern void eval(environment *env)
667  }  }
668    
669  /* Reverse (flip) a list */  /* Reverse (flip) a list */
670  extern void rev(environment *env){  extern void rev(environment *env)
671    {
672    stackitem *old_head, *new_head, *item;    stackitem *old_head, *new_head, *item;
673    
674    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 659  extern void pack(environment *env) Line 701  extern void pack(environment *env)
701    value *pack;    value *pack;
702    
703    iterator= env->head;    iterator= env->head;
704      pack= new_val(env);
705      protect(env, pack);
706    
707    if(iterator==NULL    if(iterator==NULL
708       || (iterator->item->type==symb       || (iterator->item->type==symb
# Line 676  extern void pack(environment *env) Line 720  extern void pack(environment *env)
720      temp= env->head;      temp= env->head;
721      env->head= iterator->next;      env->head= iterator->next;
722      iterator->next= NULL;      iterator->next= NULL;
723    
724        pack->type= list;
725        pack->content.ptr= temp;
726            
727      if(env->head!=NULL)      if(env->head!=NULL)
728        toss(env);        toss(env);
729    }    }
730    
731    /* Push list */    /* Push list */
   pack= new_val(env);  
   pack->type= list;  
   pack->content.ptr= temp;  
732    
733    push_val(env, pack);    push_val(env, pack);
734    rev(env);    rev(env);
735    
736      unprotect(env);
737  }  }
738    
739  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
# Line 765  extern void not(environment *env) Line 811  extern void not(environment *env)
811      return;      return;
812    }    }
813    
814    val= env->head->item->content.val;    val= env->head->item->content.i;
815    toss(env);    toss(env);
816    push_int(env, !val);    push_int(env, !val);
817  }  }
# Line 808  extern void def(environment *env) Line 854  extern void def(environment *env)
854  /* Quit stack. */  /* Quit stack. */
855  extern void quit(environment *env)  extern void quit(environment *env)
856  {  {
857    long i;    int i;
858    
859    clear(env);    clear(env);
860    
# Line 821  extern void quit(environment *env) Line 867  extern void quit(environment *env)
867    }    }
868    
869    env->gc_limit= 0;    env->gc_limit= 0;
870    gc_init(env);    gc_maybe(env);
871    
872    if(env->free_string!=NULL)    if(env->free_string!=NULL)
873      free(env->free_string);      free(env->free_string);
# Line 854  extern void words(environment *env) Line 900  extern void words(environment *env)
900  }  }
901    
902  /* Internal forget function */  /* Internal forget function */
903  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
904    {
905    symbol *temp;    symbol *temp;
906    
907    temp= *hash_entry;    temp= *hash_entry;
# Line 889  extern void forget(environment *env) Line 936  extern void forget(environment *env)
936  }  }
937    
938  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
939  extern void errn(environment *env){  extern void errn(environment *env)
940    {
941    push_int(env, env->err);    push_int(env, env->err);
942  }  }
943    
# Line 958  under certain conditions; type `copying; Line 1006  under certain conditions; type `copying;
1006        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1007        eval(&myenv);        eval(&myenv);
1008      }      }
1009      gc_init(&myenv);      gc_maybe(&myenv);
1010    }    }
1011    quit(&myenv);    quit(&myenv);
1012    return EXIT_FAILURE;    return EXIT_FAILURE;
1013  }  }
1014    
1015  /* "+" */  /* "+" */
1016  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1017    {
1018    int a, b;    int a, b;
1019      float fa, fb;
1020    size_t len;    size_t len;
1021    char* new_string;    char* new_string;
1022    value *a_val, *b_val;    value *a_val, *b_val;
# Line 991  extern void sx_2b(environment *env) { Line 1041  extern void sx_2b(environment *env) {
1041      push_cstring(env, new_string);      push_cstring(env, new_string);
1042      unprotect(env); unprotect(env);      unprotect(env); unprotect(env);
1043      free(new_string);      free(new_string);
1044        
1045      return;      return;
1046    }    }
1047        
1048    if(env->head->item->type!=integer    if(env->head->item->type==integer
1049       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
1050      printerr("Bad Argument Type");      a=env->head->item->content.i;
1051      env->err=2;      toss(env); if(env->err) return;
1052        b=env->head->item->content.i;
1053        toss(env); if(env->err) return;
1054        push_int(env, b+a);
1055    
1056      return;      return;
1057    }    }
1058    a= env->head->item->content.val;  
1059    toss(env); if(env->err) return;    if(env->head->item->type==tfloat
1060           && env->head->next->item->type==tfloat) {
1061    b= env->head->item->content.val;      fa= env->head->item->content.f;
1062    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1063    push_int(env, a+b);      fb= env->head->item->content.f;
1064        toss(env); if(env->err) return;
1065        push_float(env, fb+fa);
1066        
1067        return;
1068      }
1069    
1070      if(env->head->item->type==tfloat
1071         && env->head->next->item->type==integer) {
1072        fa= env->head->item->content.f;
1073        toss(env); if(env->err) return;
1074        b= env->head->item->content.i;
1075        toss(env); if(env->err) return;
1076        push_float(env, b+fa);
1077        
1078        return;
1079      }
1080    
1081      if(env->head->item->type==integer
1082         && env->head->next->item->type==tfloat) {
1083        a= env->head->item->content.i;
1084        toss(env); if(env->err) return;
1085        fb= env->head->item->content.f;
1086        toss(env); if(env->err) return;
1087        push_float(env, fb+a);
1088    
1089        return;
1090      }
1091    
1092      printerr("Bad Argument Type");
1093      env->err=2;
1094  }  }
1095    
1096  /* "-" */  /* "-" */
1097  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1098    {
1099    int a, b;    int a, b;
1100      float fa, fb;
1101    
1102    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1103      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 1018  extern void sx_2d(environment *env) { Line 1105  extern void sx_2d(environment *env) {
1105      return;      return;
1106    }    }
1107        
1108    if(env->head->item->type!=integer    if(env->head->item->type==integer
1109       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
1110      printerr("Bad Argument Type");      a=env->head->item->content.i;
1111      env->err=2;      toss(env); if(env->err) return;
1112        b=env->head->item->content.i;
1113        toss(env); if(env->err) return;
1114        push_int(env, b-a);
1115    
1116      return;      return;
1117    }    }
1118    
1119    a=env->head->item->content.val;    if(env->head->item->type==tfloat
1120    toss(env); if(env->err) return;       && env->head->next->item->type==tfloat) {
1121    b=env->head->item->content.val;      fa= env->head->item->content.f;
1122    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1123    push_int(env, b-a);      fb= env->head->item->content.f;
1124        toss(env); if(env->err) return;
1125        push_float(env, fb-fa);
1126        
1127        return;
1128      }
1129    
1130      if(env->head->item->type==tfloat
1131         && env->head->next->item->type==integer) {
1132        fa= env->head->item->content.f;
1133        toss(env); if(env->err) return;
1134        b= env->head->item->content.i;
1135        toss(env); if(env->err) return;
1136        push_float(env, b-fa);
1137        
1138        return;
1139      }
1140    
1141      if(env->head->item->type==integer
1142         && env->head->next->item->type==tfloat) {
1143        a= env->head->item->content.i;
1144        toss(env); if(env->err) return;
1145        fb= env->head->item->content.f;
1146        toss(env); if(env->err) return;
1147        push_float(env, fb-a);
1148    
1149        return;
1150      }
1151    
1152      printerr("Bad Argument Type");
1153      env->err=2;
1154  }  }
1155    
1156  /* ">" */  /* ">" */
1157  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1158    {
1159    int a, b;    int a, b;
1160      float fa, fb;
1161    
1162    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1163      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 1042  extern void sx_3e(environment *env) { Line 1165  extern void sx_3e(environment *env) {
1165      return;      return;
1166    }    }
1167        
1168    if(env->head->item->type!=integer    if(env->head->item->type==integer
1169       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
1170      printerr("Bad Argument Type");      a=env->head->item->content.i;
1171      env->err=2;      toss(env); if(env->err) return;
1172        b=env->head->item->content.i;
1173        toss(env); if(env->err) return;
1174        push_int(env, b>a);
1175    
1176      return;      return;
1177    }    }
1178    
1179    a=env->head->item->content.val;    if(env->head->item->type==tfloat
1180    toss(env); if(env->err) return;       && env->head->next->item->type==tfloat) {
1181    b=env->head->item->content.val;      fa= env->head->item->content.f;
1182    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1183    push_int(env, b>a);      fb= env->head->item->content.f;
1184        toss(env); if(env->err) return;
1185        push_int(env, fb>fa);
1186        
1187        return;
1188      }
1189    
1190      if(env->head->item->type==tfloat
1191         && env->head->next->item->type==integer) {
1192        fa= env->head->item->content.f;
1193        toss(env); if(env->err) return;
1194        b= env->head->item->content.i;
1195        toss(env); if(env->err) return;
1196        push_int(env, b>fa);
1197        
1198        return;
1199      }
1200    
1201      if(env->head->item->type==integer
1202         && env->head->next->item->type==tfloat) {
1203        a= env->head->item->content.i;
1204        toss(env); if(env->err) return;
1205        fb= env->head->item->content.f;
1206        toss(env); if(env->err) return;
1207        push_int(env, fb>a);
1208    
1209        return;
1210      }
1211    
1212      printerr("Bad Argument Type");
1213      env->err=2;
1214    }
1215    
1216    /* "<" */
1217    extern void sx_3c(environment *env)
1218    {
1219      swap(env); if(env->err) return;
1220      sx_3e(env);
1221    }
1222    
1223    /* "<=" */
1224    extern void sx_3c3d(environment *env)
1225    {
1226      sx_3e(env); if(env->err) return;
1227      not(env);
1228    }
1229    
1230    /* ">=" */
1231    extern void sx_3e3d(environment *env)
1232    {
1233      sx_3c(env); if(env->err) return;
1234      not(env);
1235  }  }
1236    
1237  /* Return copy of a value */  /* Return copy of a value */
1238  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1239    {
1240    stackitem *old_item, *new_item, *prev_item;    stackitem *old_item, *new_item, *prev_item;
1241      value *new_value;
   value *new_value= new_val(env);  
1242    
1243    protect(env, old_value);    protect(env, old_value);
1244      new_value= new_val(env);
1245      protect(env, new_value);
1246    new_value->type= old_value->type;    new_value->type= old_value->type;
1247    
1248    switch(old_value->type){    switch(old_value->type){
1249      case tfloat:
1250    case integer:    case integer:
1251      new_value->content.val= old_value->content.val;    case func:
1252      case symb:
1253        new_value->content= old_value->content;
1254      break;      break;
1255    case string:    case string:
1256      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1257        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1258      break;      break;
   case func:  
   case symb:  
     new_value->content.ptr= old_value->content.ptr;  
     break;  
1259    case list:    case list:
1260      new_value->content.ptr= NULL;      new_value->content.ptr= NULL;
1261    
# Line 1098  value *copy_val(environment *env, value Line 1277  value *copy_val(environment *env, value
1277      break;      break;
1278    }    }
1279    
1280    unprotect(env);    unprotect(env); unprotect(env);
1281    
1282    return new_value;    return new_value;
1283  }  }
1284    
1285  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1286  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1287    {
1288    if((env->head)==NULL) {    if((env->head)==NULL) {
1289      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1290      env->err= 1;      env->err= 1;
# Line 1114  extern void sx_647570(environment *env) Line 1294  extern void sx_647570(environment *env)
1294  }  }
1295    
1296  /* "if", If-Then */  /* "if", If-Then */
1297  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1298    {
1299    int truth;    int truth;
1300    
1301    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
# Line 1133  extern void sx_6966(environment *env) { Line 1313  extern void sx_6966(environment *env) {
1313    swap(env);    swap(env);
1314    if(env->err) return;    if(env->err) return;
1315        
1316    truth=env->head->item->content.val;    truth=env->head->item->content.i;
1317    
1318    toss(env);    toss(env);
1319    if(env->err) return;    if(env->err) return;
# Line 1145  extern void sx_6966(environment *env) { Line 1325  extern void sx_6966(environment *env) {
1325  }  }
1326    
1327  /* If-Then-Else */  /* If-Then-Else */
1328  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1329    {
1330    int truth;    int truth;
1331    
1332    if((env->head)==NULL || env->head->next==NULL    if((env->head)==NULL || env->head->next==NULL
# Line 1165  extern void ifelse(environment *env) { Line 1345  extern void ifelse(environment *env) {
1345    rot(env);    rot(env);
1346    if(env->err) return;    if(env->err) return;
1347        
1348    truth=env->head->item->content.val;    truth=env->head->item->content.i;
1349    
1350    toss(env);    toss(env);
1351    if(env->err) return;    if(env->err) return;
# Line 1181  extern void ifelse(environment *env) { Line 1361  extern void ifelse(environment *env) {
1361  }  }
1362    
1363  /* "while" */  /* "while" */
1364  extern void sx_7768696c65(environment *env) {  extern void sx_7768696c65(environment *env)
1365    {
1366    int truth;    int truth;
1367    value *loop, *test;    value *loop, *test;
1368    
# Line 1210  extern void sx_7768696c65(environment *e Line 1390  extern void sx_7768696c65(environment *e
1390        return;        return;
1391      }      }
1392            
1393      truth= env->head->item->content.val;      truth= env->head->item->content.i;
1394      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1395            
1396      if(truth) {      if(truth) {
# Line 1227  extern void sx_7768696c65(environment *e Line 1407  extern void sx_7768696c65(environment *e
1407    
1408    
1409  /* "for"; for-loop */  /* "for"; for-loop */
1410  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1411    {
1412    value *loop;    value *loop;
1413    int foo1, foo2;    int foo1, foo2;
1414    
# Line 1249  extern void sx_666f72(environment *env) Line 1430  extern void sx_666f72(environment *env)
1430    protect(env, loop);    protect(env, loop);
1431    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1432    
1433    foo2= env->head->item->content.val;    foo2= env->head->item->content.i;
1434    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1435    
1436    foo1= env->head->item->content.val;    foo1= env->head->item->content.i;
1437    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1438    
1439    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1274  extern void sx_666f72(environment *env) Line 1455  extern void sx_666f72(environment *env)
1455  }  }
1456    
1457  /* Variant of for-loop */  /* Variant of for-loop */
1458  extern void foreach(environment *env) {  extern void foreach(environment *env)
1459      {  
1460    value *loop, *foo;    value *loop, *foo;
1461    stackitem *iterator;    stackitem *iterator;
1462        
# Line 1311  extern void foreach(environment *env) { Line 1492  extern void foreach(environment *env) {
1492  }  }
1493    
1494  /* "to" */  /* "to" */
1495  extern void to(environment *env) {  extern void to(environment *env)
1496    int i, start, ending;  {
1497    stackitem *temp_head;    int ending, start, i;
1498    value *temp_val;    stackitem *iterator, *temp;
1499        value *pack;
1500    
1501    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1502      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1503      env->err=1;      env->err=1;
# Line 1329  extern void to(environment *env) { Line 1511  extern void to(environment *env) {
1511      return;      return;
1512    }    }
1513    
1514    ending= env->head->item->content.val;    ending= env->head->item->content.i;
1515    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1516    start= env->head->item->content.val;    start= env->head->item->content.i;
1517    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1518    
1519    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1520    
1521    if(ending>=start) {    if(ending>=start) {
1522      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1345  extern void to(environment *env) { Line 1526  extern void to(environment *env) {
1526        push_int(env, i);        push_int(env, i);
1527    }    }
1528    
1529    temp_val= new_val(env);    iterator= env->head;
1530    temp_val->content.ptr= env->head;    pack= new_val(env);
1531    temp_val->type= list;    protect(env, pack);
1532    env->head= temp_head;  
1533    push_val(env, temp_val);    if(iterator==NULL
1534         || (iterator->item->type==symb
1535         && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {
1536        temp= NULL;
1537        toss(env);
1538      } else {
1539        /* Search for first delimiter */
1540        while(iterator->next!=NULL
1541              && (iterator->next->item->type!=symb
1542              || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))
1543          iterator= iterator->next;
1544        
1545        /* Extract list */
1546        temp= env->head;
1547        env->head= iterator->next;
1548        iterator->next= NULL;
1549    
1550        pack->type= list;
1551        pack->content.ptr= temp;
1552        
1553        if(env->head!=NULL)
1554          toss(env);
1555      }
1556    
1557      /* Push list */
1558    
1559      push_val(env, pack);
1560    
1561      unprotect(env);
1562  }  }
1563    
1564  /* Read a string */  /* Read a string */
1565  extern void readline(environment *env) {  extern void readline(environment *env)
1566    {
1567    char in_string[101];    char in_string[101];
1568    
1569    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1363  extern void readline(environment *env) { Line 1573  extern void readline(environment *env) {
1573  }  }
1574    
1575  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1576  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1577    {
1578    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1579    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1580    const char intform[]= "%i%n";    const char intform[]= "%i%n";
1581      const char fltform[]= "%f%n";
1582    const char blankform[]= "%*[ \t]%n";    const char blankform[]= "%*[ \t]%n";
1583    const char ebrackform[]= "]%n";    const char ebrackform[]= "]%n";
1584    const char semicform[]= ";%n";    const char semicform[]= ";%n";
1585    const char bbrackform[]= "[%n";    const char bbrackform[]= "[%n";
1586    
1587    int itemp, readlength= -1;    int itemp, readlength= -1;
1588      int count= -1;
1589      float ftemp;
1590    static int depth= 0;    static int depth= 0;
1591    char *match;    char *match, *ctemp;
1592    size_t inlength;    size_t inlength;
1593    
1594    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1397  extern void sx_72656164(environment *env Line 1611  extern void sx_72656164(environment *env
1611    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1612    match= malloc(inlength);    match= malloc(inlength);
1613    
1614    if(sscanf(env->in_string, blankform, &readlength)!=EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1615       && readlength != -1) {       && readlength != -1) {
1616      ;      ;
1617    } else if(sscanf(env->in_string, intform, &itemp, &readlength) != EOF    } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
1618              && readlength != -1) {              && readlength != -1) {
1619      push_int(env, itemp);      if(sscanf(env->in_string, intform, &itemp, &count) != EOF
1620           && count==readlength) {
1621          push_int(env, itemp);
1622        } else {
1623          push_float(env, ftemp);
1624        }
1625    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1626              && readlength != -1) {              && readlength != -1) {
1627      push_cstring(env, match);      push_cstring(env, match);
# Line 1424  extern void sx_72656164(environment *env Line 1643  extern void sx_72656164(environment *env
1643      free(env->free_string);      free(env->free_string);
1644      env->in_string = env->free_string = NULL;      env->in_string = env->free_string = NULL;
1645    }    }
1646    if ( env->in_string != NULL) {    if (env->in_string != NULL) {
1647      env->in_string += readlength;      env->in_string += readlength;
1648    }    }
1649    
# Line 1434  extern void sx_72656164(environment *env Line 1653  extern void sx_72656164(environment *env
1653      return sx_72656164(env);      return sx_72656164(env);
1654  }  }
1655    
1656  extern void beep(environment *env) {  extern void beep(environment *env)
1657    {
1658    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1659    
1660    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
# Line 1451  extern void beep(environment *env) { Line 1670  extern void beep(environment *env) {
1670      return;      return;
1671    }    }
1672    
1673    dur=env->head->item->content.val;    dur=env->head->item->content.i;
1674    toss(env);    toss(env);
1675    freq=env->head->item->content.val;    freq=env->head->item->content.i;
1676    toss(env);    toss(env);
1677    
1678    period=1193180/freq;          /* convert freq from Hz to period    period=1193180/freq;          /* convert freq from Hz to period
# Line 1475  extern void beep(environment *env) { Line 1694  extern void beep(environment *env) {
1694    default:    default:
1695      abort();      abort();
1696    }    }
1697  };  }
1698    
1699  /* "wait" */  /* "wait" */
1700  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1701    {
1702    int dur;    int dur;
1703    
1704    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 1494  extern void sx_77616974(environment *env Line 1713  extern void sx_77616974(environment *env
1713      return;      return;
1714    }    }
1715    
1716    dur=env->head->item->content.val;    dur=env->head->item->content.i;
1717    toss(env);    toss(env);
1718    
1719    usleep(dur);    usleep(dur);
1720  };  }
1721    
1722  extern void copying(environment *env){  extern void copying(environment *env)
1723    {
1724    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1725                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1726  \n\  \n\
# Line 1759  of preserving the free status of all der Line 1979  of preserving the free status of all der
1979  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
1980  }  }
1981    
1982  extern void warranty(environment *env){  extern void warranty(environment *env)
1983    {
1984    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
1985  \n\  \n\
1986    11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\    11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\
# Line 1782  YOU OR THIRD PARTIES OR A FAILURE OF THE Line 2003  YOU OR THIRD PARTIES OR A FAILURE OF THE
2003  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE\n\  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE\n\
2004  POSSIBILITY OF SUCH DAMAGES.\n");  POSSIBILITY OF SUCH DAMAGES.\n");
2005  }  }
2006    
2007    /* "*" */
2008    extern void sx_2a(environment *env)
2009    {
2010      int a, b;
2011      float fa, fb;
2012    
2013      if((env->head)==NULL || env->head->next==NULL) {
2014        printerr("Too Few Arguments");
2015        env->err=1;
2016        return;
2017      }
2018      
2019      if(env->head->item->type==integer
2020         && env->head->next->item->type==integer) {
2021        a=env->head->item->content.i;
2022        toss(env); if(env->err) return;
2023        b=env->head->item->content.i;
2024        toss(env); if(env->err) return;
2025        push_int(env, b*a);
2026    
2027        return;
2028      }
2029    
2030      if(env->head->item->type==tfloat
2031         && env->head->next->item->type==tfloat) {
2032        fa= env->head->item->content.f;
2033        toss(env); if(env->err) return;
2034        fb= env->head->item->content.f;
2035        toss(env); if(env->err) return;
2036        push_float(env, fb*fa);
2037        
2038        return;
2039      }
2040    
2041      if(env->head->item->type==tfloat
2042         && env->head->next->item->type==integer) {
2043        fa= env->head->item->content.f;
2044        toss(env); if(env->err) return;
2045        b= env->head->item->content.i;
2046        toss(env); if(env->err) return;
2047        push_float(env, b*fa);
2048        
2049        return;
2050      }
2051    
2052      if(env->head->item->type==integer
2053         && env->head->next->item->type==tfloat) {
2054        a= env->head->item->content.i;
2055        toss(env); if(env->err) return;
2056        fb= env->head->item->content.f;
2057        toss(env); if(env->err) return;
2058        push_float(env, fb*a);
2059    
2060        return;
2061      }
2062    
2063      printerr("Bad Argument Type");
2064      env->err=2;
2065    }
2066    
2067    /* "/" */
2068    extern void sx_2f(environment *env)
2069    {
2070      int a, b;
2071      float fa, fb;
2072    
2073      if((env->head)==NULL || env->head->next==NULL) {
2074        printerr("Too Few Arguments");
2075        env->err=1;
2076        return;
2077      }
2078      
2079      if(env->head->item->type==integer
2080         && env->head->next->item->type==integer) {
2081        a=env->head->item->content.i;
2082        toss(env); if(env->err) return;
2083        b=env->head->item->content.i;
2084        toss(env); if(env->err) return;
2085        push_float(env, b/a);
2086    
2087        return;
2088      }
2089    
2090      if(env->head->item->type==tfloat
2091         && env->head->next->item->type==tfloat) {
2092        fa= env->head->item->content.f;
2093        toss(env); if(env->err) return;
2094        fb= env->head->item->content.f;
2095        toss(env); if(env->err) return;
2096        push_float(env, fb/fa);
2097        
2098        return;
2099      }
2100    
2101      if(env->head->item->type==tfloat
2102         && env->head->next->item->type==integer) {
2103        fa= env->head->item->content.f;
2104        toss(env); if(env->err) return;
2105        b= env->head->item->content.i;
2106        toss(env); if(env->err) return;
2107        push_float(env, b/fa);
2108        
2109        return;
2110      }
2111    
2112      if(env->head->item->type==integer
2113         && env->head->next->item->type==tfloat) {
2114        a= env->head->item->content.i;
2115        toss(env); if(env->err) return;
2116        fb= env->head->item->content.f;
2117        toss(env); if(env->err) return;
2118        push_float(env, fb/a);
2119    
2120        return;
2121      }
2122    
2123      printerr("Bad Argument Type");
2124      env->err=2;
2125    }
2126    
2127    /* "mod" */
2128    extern void mod(environment *env)
2129    {
2130      int a, b;
2131    
2132      if((env->head)==NULL || env->head->next==NULL) {
2133        printerr("Too Few Arguments");
2134        env->err= 1;
2135        return;
2136      }
2137      
2138      if(env->head->item->type==integer
2139         && env->head->next->item->type==integer) {
2140        a= env->head->item->content.i;
2141        toss(env); if(env->err) return;
2142        b= env->head->item->content.i;
2143        toss(env); if(env->err) return;
2144        push_int(env, b%a);
2145    
2146        return;
2147      }
2148    
2149      printerr("Bad Argument Type");
2150      env->err=2;
2151    }
2152    
2153    /* "div" */
2154    extern void sx_646976(environment *env)
2155    {
2156      int a, b;
2157      
2158      if((env->head)==NULL || env->head->next==NULL) {
2159        printerr("Too Few Arguments");
2160        env->err= 1;
2161        return;
2162      }
2163    
2164      if(env->head->item->type==integer
2165         && env->head->next->item->type==integer) {
2166        a= env->head->item->content.i;
2167        toss(env); if(env->err) return;
2168        b= env->head->item->content.i;
2169        toss(env); if(env->err) return;
2170        push_int(env, (int)b/a);
2171    
2172        return;
2173      }
2174    
2175      printerr("Bad Argument Type");
2176      env->err= 2;
2177    }
Legend:
Removed from v.1.91  
changed lines
  Added in v.1.97
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26