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

Diff of /stack/stack.c

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

revision 1.92 by masse, Fri Mar 8 06:44:15 2002 UTC revision 1.96 by teddy, Sun Mar 10 07:55:13 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++;
   unprotect(env);  
130    
131    return nval;    return nval;
132  }  }
133    
134  void gc_mark(value *val) {  /* Mark values recursively.
135       Marked values are not collected by the GC. */
136    inline void gc_mark(value *val)
137    {
138    stackitem *iterator;    stackitem *iterator;
139    
140    if(val==NULL || val->gc_garb==0)    if(val==NULL || val->gc_garb==0)
# Line 150  void gc_mark(value *val) { Line 152  void gc_mark(value *val) {
152    }    }
153  }  }
154    
155  extern void gc_init(environment *env) {  inline void gc_maybe(environment *env)
156    stackitem *new_head= NULL, *titem, *iterator= env->gc_ref;  {
   symbol *tsymb;  
   int i;  
   
157    if(env->gc_count < env->gc_limit)    if(env->gc_count < env->gc_limit)
158      return;      return;
159      else
160        return gc_init(env);
161    }
162    
163    /* Start GC */
164    extern void gc_init(environment *env)
165    {
166      stackitem *new_head= NULL, *titem, *iterator;
167      symbol *tsymb;
168      int i;
169    
170      /* Garb by default */
171      iterator= env->gc_ref;
172    while(iterator!=NULL) {    while(iterator!=NULL) {
173      iterator->item->gc_garb= 1;      iterator->item->gc_garb= 1;
174      iterator= iterator->next;      iterator= iterator->next;
175    }    }
176    
177    /* Mark */    /* Mark protected values */
178    iterator= env->gc_protect;    iterator= env->gc_protect;
179    while(iterator!=NULL) {    while(iterator!=NULL) {
180      gc_mark(iterator->item);      gc_mark(iterator->item);
181      iterator= iterator->next;      iterator= iterator->next;
182    }    }
183    
184      /* Mark values on stack */
185    iterator= env->head;    iterator= env->head;
186    while(iterator!=NULL) {    while(iterator!=NULL) {
187      gc_mark(iterator->item);      gc_mark(iterator->item);
188      iterator= iterator->next;      iterator= iterator->next;
189    }    }
190    
191      /* Mark values in hashtable */
192    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
193      tsymb= env->symbols[i];      tsymb= env->symbols[i];
194      while(tsymb!=NULL) {      while(tsymb!=NULL) {
# Line 186  extern void gc_init(environment *env) { Line 199  extern void gc_init(environment *env) {
199    
200    env->gc_count= 0;    env->gc_count= 0;
201    
202    /* Sweep */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
   while(env->gc_ref!=NULL) {  
203    
204      if(env->gc_ref->item->gc_garb) {      if(env->gc_ref->item->gc_garb) {
205        switch(env->gc_ref->item->type) {  
206          switch(env->gc_ref->item->type) { /* Remove content */
207        case string:        case string:
208          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
209          break;          break;
       case integer:  
         break;  
210        case list:        case list:
211          while(env->gc_ref->item->content.ptr!=NULL) {          while(env->gc_ref->item->content.ptr!=NULL) {
212            titem= env->gc_ref->item->content.ptr;            titem= env->gc_ref->item->content.ptr;
# Line 206  extern void gc_init(environment *env) { Line 217  extern void gc_init(environment *env) {
217        default:        default:
218          break;          break;
219        }        }
220        free(env->gc_ref->item);        free(env->gc_ref->item);  /* Remove from gc_ref */
221        titem= env->gc_ref->next;        titem= env->gc_ref->next;
222        free(env->gc_ref);        free(env->gc_ref);        /* Remove value */
223        env->gc_ref= titem;        env->gc_ref= titem;
224      } else {      } else {                    /* Keep values */
225        titem= env->gc_ref->next;        titem= env->gc_ref->next;
226        env->gc_ref->next= new_head;        env->gc_ref->next= new_head;
227        new_head= env->gc_ref;        new_head= env->gc_ref;
# Line 223  extern void gc_init(environment *env) { Line 234  extern void gc_init(environment *env) {
234    env->gc_ref= new_head;    env->gc_ref= new_head;
235  }  }
236    
237    /* Protect values from GC */
238  void protect(environment *env, value *val)  void protect(environment *env, value *val)
239  {  {
240    stackitem *new_item= malloc(sizeof(stackitem));    stackitem *new_item= malloc(sizeof(stackitem));
# Line 231  void protect(environment *env, value *va Line 243  void protect(environment *env, value *va
243    env->gc_protect= new_item;    env->gc_protect= new_item;
244  }  }
245    
246    /* Unprotect values from GC */
247  void unprotect(environment *env)  void unprotect(environment *env)
248  {  {
249    stackitem *temp= env->gc_protect;    stackitem *temp= env->gc_protect;
# Line 247  void push_val(environment *env, value *v Line 260  void push_val(environment *env, value *v
260    env->head= new_item;    env->head= new_item;
261  }  }
262    
263  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
264  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
265  {  {
266    value *new_value= new_val(env);    value *new_value= new_val(env);
267        
268    new_value->content.val= in_val;    new_value->content.i= in_val;
269    new_value->type= integer;    new_value->type= integer;
270    
271    push_val(env, new_value);    push_val(env, new_value);
272  }  }
273    
274    /* Push a floating point number onto the stack */
275    void push_float(environment *env, float in_val)
276    {
277      value *new_value= new_val(env);
278    
279      new_value->content.f= in_val;
280      new_value->type= tfloat;
281    
282      push_val(env, new_value);
283    }
284    
285  /* Copy a string onto the stack. */  /* Copy a string onto the stack. */
286  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
287  {  {
# Line 271  void push_cstring(environment *env, cons Line 295  void push_cstring(environment *env, cons
295  }  }
296    
297  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
298  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
299    {
300    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
301    char *new_string, *current;    char *new_string, *current;
302    
# Line 289  char *mangle_str(const char *old_string) Line 314  char *mangle_str(const char *old_string)
314    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
315  }  }
316    
317  extern void mangle(environment *env){  extern void mangle(environment *env)
318    {
319    char *new_string;    char *new_string;
320    
321    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 328  void push_sym(environment *env, const ch Line 354  void push_sym(environment *env, const ch
354    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
355    
356    new_value= new_val(env);    new_value= new_val(env);
357      protect(env, new_value);
358      new_fvalue= new_val(env);
359      protect(env, new_fvalue);
360    
361    /* The new value is a symbol */    /* The new value is a symbol */
362    new_value->type= symb;    new_value->type= symb;
# Line 355  void push_sym(environment *env, const ch Line 384  void push_sym(environment *env, const ch
384    
385      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
386      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
387      free(mangled);  
388      dlerr= dlerror();      dlerr= dlerror();
389      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
390        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
391        dlerr= dlerror();        dlerr= dlerror();
392      }      }
393    
394      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 */  
395        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
396        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
397        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
398                                           function value */                                           function value */
399      }      }
400    
401        free(mangled);
402    }    }
403    
404    push_val(env, new_value);    push_val(env, new_value);
405      unprotect(env); unprotect(env);
406  }  }
407    
408  /* Print newline. */  /* Print newline. */
# Line 379  extern void nl() Line 412  extern void nl()
412  }  }
413    
414  /* Gets the type of a value */  /* Gets the type of a value */
415  extern void type(environment *env){  extern void type(environment *env)
416    {
417    int typenum;    int typenum;
418    
419    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 393  extern void type(environment *env){ Line 427  extern void type(environment *env){
427    case integer:    case integer:
428      push_sym(env, "integer");      push_sym(env, "integer");
429      break;      break;
430      case tfloat:
431        push_sym(env, "float");
432        break;
433    case string:    case string:
434      push_sym(env, "string");      push_sym(env, "string");
435      break;      break;
# Line 413  void print_h(stackitem *stack_head, int Line 450  void print_h(stackitem *stack_head, int
450  {  {
451    switch(stack_head->item->type) {    switch(stack_head->item->type) {
452    case integer:    case integer:
453      printf("%d", stack_head->item->content.val);      printf("%d", stack_head->item->content.i);
454        break;
455      case tfloat:
456        printf("%f", stack_head->item->content.f);
457      break;      break;
458    case string:    case string:
459      if(noquote)      if(noquote)
# Line 441  void print_h(stackitem *stack_head, int Line 481  void print_h(stackitem *stack_head, int
481    }    }
482  }  }
483    
484  extern void print_(environment *env) {  extern void print_(environment *env)
485    {
486    if(env->head==NULL) {    if(env->head==NULL) {
487      printerr("Too Few Arguments");      printerr("Too Few Arguments");
488      env->err=1;      env->err=1;
# Line 459  extern void print(environment *env) Line 500  extern void print(environment *env)
500    toss(env);    toss(env);
501  }  }
502    
503  extern void princ_(environment *env) {  extern void princ_(environment *env)
504    {
505    if(env->head==NULL) {    if(env->head==NULL) {
506      printerr("Too Few Arguments");      printerr("Too Few Arguments");
507      env->err=1;      env->err=1;
# Line 493  extern void printstack(environment *env) Line 535  extern void printstack(environment *env)
535      printf("Stack Empty\n");      printf("Stack Empty\n");
536      return;      return;
537    }    }
538    
539    print_st(env->head, 1);    print_st(env->head, 1);
540  }  }
541    
# Line 570  extern void eval(environment *env) Line 613  extern void eval(environment *env)
613    
614   eval_start:   eval_start:
615    
616      gc_maybe(env);
617    
618    if(env->head==NULL) {    if(env->head==NULL) {
619      printerr("Too Few Arguments");      printerr("Too Few Arguments");
620      env->err=1;      env->err=1;
# Line 597  extern void eval(environment *env) Line 642  extern void eval(environment *env)
642    case list:    case list:
643      temp_val= env->head->item;      temp_val= env->head->item;
644      protect(env, temp_val);      protect(env, temp_val);
645      toss(env);  
646      if(env->err) return;      toss(env); if(env->err) return;
647      iterator= (stackitem*)temp_val->content.ptr;      iterator= (stackitem*)temp_val->content.ptr;
     unprotect(env);  
648            
649      while(iterator!=NULL) {      while(iterator!=NULL) {
650        push_val(env, iterator->item);        push_val(env, iterator->item);
# Line 618  extern void eval(environment *env) Line 662  extern void eval(environment *env)
662        }        }
663        iterator= iterator->next;        iterator= iterator->next;
664      }      }
665        unprotect(env);
666      return;      return;
667    
668    default:    default:
# Line 626  extern void eval(environment *env) Line 671  extern void eval(environment *env)
671  }  }
672    
673  /* Reverse (flip) a list */  /* Reverse (flip) a list */
674  extern void rev(environment *env){  extern void rev(environment *env)
675    {
676    stackitem *old_head, *new_head, *item;    stackitem *old_head, *new_head, *item;
677    
678    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 659  extern void pack(environment *env) Line 705  extern void pack(environment *env)
705    value *pack;    value *pack;
706    
707    iterator= env->head;    iterator= env->head;
708      pack= new_val(env);
709      protect(env, pack);
710    
711    if(iterator==NULL    if(iterator==NULL
712       || (iterator->item->type==symb       || (iterator->item->type==symb
# Line 676  extern void pack(environment *env) Line 724  extern void pack(environment *env)
724      temp= env->head;      temp= env->head;
725      env->head= iterator->next;      env->head= iterator->next;
726      iterator->next= NULL;      iterator->next= NULL;
727    
728        pack->type= list;
729        pack->content.ptr= temp;
730            
731      if(env->head!=NULL)      if(env->head!=NULL)
732        toss(env);        toss(env);
733    }    }
734    
735    /* Push list */    /* Push list */
   pack= new_val(env);  
   pack->type= list;  
   pack->content.ptr= temp;  
736    
737    push_val(env, pack);    push_val(env, pack);
738    rev(env);    rev(env);
739    
740      unprotect(env);
741  }  }
742    
743  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
# Line 765  extern void not(environment *env) Line 815  extern void not(environment *env)
815      return;      return;
816    }    }
817    
818    val= env->head->item->content.val;    val= env->head->item->content.i;
819    toss(env);    toss(env);
820    push_int(env, !val);    push_int(env, !val);
821  }  }
# Line 808  extern void def(environment *env) Line 858  extern void def(environment *env)
858  /* Quit stack. */  /* Quit stack. */
859  extern void quit(environment *env)  extern void quit(environment *env)
860  {  {
861    long i;    int i;
862    
863    clear(env);    clear(env);
864    
# Line 821  extern void quit(environment *env) Line 871  extern void quit(environment *env)
871    }    }
872    
873    env->gc_limit= 0;    env->gc_limit= 0;
874    gc_init(env);    gc_maybe(env);
875    
876    if(env->free_string!=NULL)    if(env->free_string!=NULL)
877      free(env->free_string);      free(env->free_string);
# Line 854  extern void words(environment *env) Line 904  extern void words(environment *env)
904  }  }
905    
906  /* Internal forget function */  /* Internal forget function */
907  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
908    {
909    symbol *temp;    symbol *temp;
910    
911    temp= *hash_entry;    temp= *hash_entry;
# Line 889  extern void forget(environment *env) Line 940  extern void forget(environment *env)
940  }  }
941    
942  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
943  extern void errn(environment *env){  extern void errn(environment *env)
944    {
945    push_int(env, env->err);    push_int(env, env->err);
946  }  }
947    
# Line 958  under certain conditions; type `copying; Line 1010  under certain conditions; type `copying;
1010        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1011        eval(&myenv);        eval(&myenv);
1012      }      }
1013      gc_init(&myenv);      gc_maybe(&myenv);
1014    }    }
1015    quit(&myenv);    quit(&myenv);
1016    return EXIT_FAILURE;    return EXIT_FAILURE;
1017  }  }
1018    
1019  /* "+" */  /* "+" */
1020  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1021    {
1022    int a, b;    int a, b;
1023      float fa, fb;
1024    size_t len;    size_t len;
1025    char* new_string;    char* new_string;
1026    value *a_val, *b_val;    value *a_val, *b_val;
# Line 991  extern void sx_2b(environment *env) { Line 1045  extern void sx_2b(environment *env) {
1045      push_cstring(env, new_string);      push_cstring(env, new_string);
1046      unprotect(env); unprotect(env);      unprotect(env); unprotect(env);
1047      free(new_string);      free(new_string);
1048        
1049      return;      return;
1050    }    }
1051        
1052    if(env->head->item->type!=integer    if(env->head->item->type==integer
1053       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
1054      printerr("Bad Argument Type");      a=env->head->item->content.i;
1055      env->err=2;      toss(env); if(env->err) return;
1056        b=env->head->item->content.i;
1057        toss(env); if(env->err) return;
1058        push_int(env, b+a);
1059    
1060      return;      return;
1061    }    }
1062    a= env->head->item->content.val;  
1063    toss(env); if(env->err) return;    if(env->head->item->type==tfloat
1064           && env->head->next->item->type==tfloat) {
1065    b= env->head->item->content.val;      fa= env->head->item->content.f;
1066    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1067    push_int(env, a+b);      fb= env->head->item->content.f;
1068        toss(env); if(env->err) return;
1069        push_float(env, fb+fa);
1070        
1071        return;
1072      }
1073    
1074      if(env->head->item->type==tfloat
1075         && env->head->next->item->type==integer) {
1076        fa= env->head->item->content.f;
1077        toss(env); if(env->err) return;
1078        b= env->head->item->content.i;
1079        toss(env); if(env->err) return;
1080        push_float(env, b+fa);
1081        
1082        return;
1083      }
1084    
1085      if(env->head->item->type==integer
1086         && env->head->next->item->type==tfloat) {
1087        a= env->head->item->content.i;
1088        toss(env); if(env->err) return;
1089        fb= env->head->item->content.f;
1090        toss(env); if(env->err) return;
1091        push_float(env, fb+a);
1092    
1093        return;
1094      }
1095    
1096      printerr("Bad Argument Type");
1097      env->err=2;
1098  }  }
1099    
1100  /* "-" */  /* "-" */
1101  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1102    {
1103    int a, b;    int a, b;
1104      float fa, fb;
1105    
1106    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1107      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 1018  extern void sx_2d(environment *env) { Line 1109  extern void sx_2d(environment *env) {
1109      return;      return;
1110    }    }
1111        
1112    if(env->head->item->type!=integer    if(env->head->item->type==integer
1113       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
1114      printerr("Bad Argument Type");      a=env->head->item->content.i;
1115      env->err=2;      toss(env); if(env->err) return;
1116        b=env->head->item->content.i;
1117        toss(env); if(env->err) return;
1118        push_int(env, b-a);
1119    
1120      return;      return;
1121    }    }
1122    
1123    a=env->head->item->content.val;    if(env->head->item->type==tfloat
1124    toss(env); if(env->err) return;       && env->head->next->item->type==tfloat) {
1125    b=env->head->item->content.val;      fa= env->head->item->content.f;
1126    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1127    push_int(env, b-a);      fb= env->head->item->content.f;
1128        toss(env); if(env->err) return;
1129        push_float(env, fb-fa);
1130        
1131        return;
1132      }
1133    
1134      if(env->head->item->type==tfloat
1135         && env->head->next->item->type==integer) {
1136        fa= env->head->item->content.f;
1137        toss(env); if(env->err) return;
1138        b= env->head->item->content.i;
1139        toss(env); if(env->err) return;
1140        push_float(env, b-fa);
1141        
1142        return;
1143      }
1144    
1145      if(env->head->item->type==integer
1146         && env->head->next->item->type==tfloat) {
1147        a= env->head->item->content.i;
1148        toss(env); if(env->err) return;
1149        fb= env->head->item->content.f;
1150        toss(env); if(env->err) return;
1151        push_float(env, fb-a);
1152    
1153        return;
1154      }
1155    
1156      printerr("Bad Argument Type");
1157      env->err=2;
1158  }  }
1159    
1160  /* ">" */  /* ">" */
1161  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1162    {
1163    int a, b;    int a, b;
1164      float fa, fb;
1165    
1166    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1167      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 1042  extern void sx_3e(environment *env) { Line 1169  extern void sx_3e(environment *env) {
1169      return;      return;
1170    }    }
1171        
1172    if(env->head->item->type!=integer    if(env->head->item->type==integer
1173       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
1174      printerr("Bad Argument Type");      a=env->head->item->content.i;
1175      env->err=2;      toss(env); if(env->err) return;
1176        b=env->head->item->content.i;
1177        toss(env); if(env->err) return;
1178        push_int(env, b>a);
1179    
1180      return;      return;
1181    }    }
1182    
1183    a=env->head->item->content.val;    if(env->head->item->type==tfloat
1184    toss(env); if(env->err) return;       && env->head->next->item->type==tfloat) {
1185    b=env->head->item->content.val;      fa= env->head->item->content.f;
1186    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1187    push_int(env, b>a);      fb= env->head->item->content.f;
1188        toss(env); if(env->err) return;
1189        push_int(env, fb>fa);
1190        
1191        return;
1192      }
1193    
1194      if(env->head->item->type==tfloat
1195         && env->head->next->item->type==integer) {
1196        fa= env->head->item->content.f;
1197        toss(env); if(env->err) return;
1198        b= env->head->item->content.i;
1199        toss(env); if(env->err) return;
1200        push_int(env, b>fa);
1201        
1202        return;
1203      }
1204    
1205      if(env->head->item->type==integer
1206         && env->head->next->item->type==tfloat) {
1207        a= env->head->item->content.i;
1208        toss(env); if(env->err) return;
1209        fb= env->head->item->content.f;
1210        toss(env); if(env->err) return;
1211        push_int(env, fb>a);
1212    
1213        return;
1214      }
1215    
1216      printerr("Bad Argument Type");
1217      env->err=2;
1218    }
1219    
1220    /* "<" */
1221    extern void sx_3c(environment *env)
1222    {
1223      swap(env); if(env->err) return;
1224      sx_3e(env);
1225    }
1226    
1227    /* "<=" */
1228    extern void sx_3c3d(environment *env)
1229    {
1230      sx_3e(env); if(env->err) return;
1231      not(env);
1232    }
1233    
1234    /* ">=" */
1235    extern void sx_3e3d(environment *env)
1236    {
1237      sx_3c(env); if(env->err) return;
1238      not(env);
1239  }  }
1240    
1241  /* Return copy of a value */  /* Return copy of a value */
1242  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1243    {
1244    stackitem *old_item, *new_item, *prev_item;    stackitem *old_item, *new_item, *prev_item;
1245      value *new_value;
   value *new_value= new_val(env);  
1246    
1247    protect(env, old_value);    protect(env, old_value);
1248      new_value= new_val(env);
1249      protect(env, new_value);
1250    new_value->type= old_value->type;    new_value->type= old_value->type;
1251    
1252    switch(old_value->type){    switch(old_value->type){
1253      case tfloat:
1254    case integer:    case integer:
1255      new_value->content.val= old_value->content.val;    case func:
1256      case symb:
1257        new_value->content= old_value->content;
1258      break;      break;
1259    case string:    case string:
1260      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1261        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1262      break;      break;
   case func:  
   case symb:  
     new_value->content.ptr= old_value->content.ptr;  
     break;  
1263    case list:    case list:
1264      new_value->content.ptr= NULL;      new_value->content.ptr= NULL;
1265    
# Line 1098  value *copy_val(environment *env, value Line 1281  value *copy_val(environment *env, value
1281      break;      break;
1282    }    }
1283    
1284    unprotect(env);    unprotect(env); unprotect(env);
1285    
1286    return new_value;    return new_value;
1287  }  }
1288    
1289  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1290  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1291    {
1292    if((env->head)==NULL) {    if((env->head)==NULL) {
1293      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1294      env->err= 1;      env->err= 1;
# Line 1114  extern void sx_647570(environment *env) Line 1298  extern void sx_647570(environment *env)
1298  }  }
1299    
1300  /* "if", If-Then */  /* "if", If-Then */
1301  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1302    {
1303    int truth;    int truth;
1304    
1305    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 1317  extern void sx_6966(environment *env) {
1317    swap(env);    swap(env);
1318    if(env->err) return;    if(env->err) return;
1319        
1320    truth=env->head->item->content.val;    truth=env->head->item->content.i;
1321    
1322    toss(env);    toss(env);
1323    if(env->err) return;    if(env->err) return;
# Line 1145  extern void sx_6966(environment *env) { Line 1329  extern void sx_6966(environment *env) {
1329  }  }
1330    
1331  /* If-Then-Else */  /* If-Then-Else */
1332  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1333    {
1334    int truth;    int truth;
1335    
1336    if((env->head)==NULL || env->head->next==NULL    if((env->head)==NULL || env->head->next==NULL
# Line 1165  extern void ifelse(environment *env) { Line 1349  extern void ifelse(environment *env) {
1349    rot(env);    rot(env);
1350    if(env->err) return;    if(env->err) return;
1351        
1352    truth=env->head->item->content.val;    truth=env->head->item->content.i;
1353    
1354    toss(env);    toss(env);
1355    if(env->err) return;    if(env->err) return;
# Line 1181  extern void ifelse(environment *env) { Line 1365  extern void ifelse(environment *env) {
1365  }  }
1366    
1367  /* "while" */  /* "while" */
1368  extern void sx_7768696c65(environment *env) {  extern void sx_7768696c65(environment *env)
1369    {
1370    int truth;    int truth;
1371    value *loop, *test;    value *loop, *test;
1372    
# Line 1210  extern void sx_7768696c65(environment *e Line 1394  extern void sx_7768696c65(environment *e
1394        return;        return;
1395      }      }
1396            
1397      truth= env->head->item->content.val;      truth= env->head->item->content.i;
1398      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1399            
1400      if(truth) {      if(truth) {
# Line 1227  extern void sx_7768696c65(environment *e Line 1411  extern void sx_7768696c65(environment *e
1411    
1412    
1413  /* "for"; for-loop */  /* "for"; for-loop */
1414  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1415    {
1416    value *loop;    value *loop;
1417    int foo1, foo2;    int foo1, foo2;
1418    
# Line 1249  extern void sx_666f72(environment *env) Line 1434  extern void sx_666f72(environment *env)
1434    protect(env, loop);    protect(env, loop);
1435    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1436    
1437    foo2= env->head->item->content.val;    foo2= env->head->item->content.i;
1438    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1439    
1440    foo1= env->head->item->content.val;    foo1= env->head->item->content.i;
1441    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1442    
1443    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1274  extern void sx_666f72(environment *env) Line 1459  extern void sx_666f72(environment *env)
1459  }  }
1460    
1461  /* Variant of for-loop */  /* Variant of for-loop */
1462  extern void foreach(environment *env) {  extern void foreach(environment *env)
1463      {  
1464    value *loop, *foo;    value *loop, *foo;
1465    stackitem *iterator;    stackitem *iterator;
1466        
# Line 1311  extern void foreach(environment *env) { Line 1496  extern void foreach(environment *env) {
1496  }  }
1497    
1498  /* "to" */  /* "to" */
1499  extern void to(environment *env) {  extern void to(environment *env)
1500    int i, start, ending;  {
1501    stackitem *temp_head;    int ending, start, i;
1502    value *temp_val;    stackitem *iterator, *temp;
1503        value *pack;
1504    
1505    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1506      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1507      env->err=1;      env->err=1;
# Line 1329  extern void to(environment *env) { Line 1515  extern void to(environment *env) {
1515      return;      return;
1516    }    }
1517    
1518    ending= env->head->item->content.val;    ending= env->head->item->content.i;
1519    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1520    start= env->head->item->content.val;    start= env->head->item->content.i;
1521    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1522    
1523    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1524    
1525    if(ending>=start) {    if(ending>=start) {
1526      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1345  extern void to(environment *env) { Line 1530  extern void to(environment *env) {
1530        push_int(env, i);        push_int(env, i);
1531    }    }
1532    
1533    temp_val= new_val(env);    iterator= env->head;
1534    temp_val->content.ptr= env->head;    pack= new_val(env);
1535    temp_val->type= list;    protect(env, pack);
1536    env->head= temp_head;  
1537    push_val(env, temp_val);    if(iterator==NULL
1538         || (iterator->item->type==symb
1539         && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {
1540        temp= NULL;
1541        toss(env);
1542      } else {
1543        /* Search for first delimiter */
1544        while(iterator->next!=NULL
1545              && (iterator->next->item->type!=symb
1546              || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))
1547          iterator= iterator->next;
1548        
1549        /* Extract list */
1550        temp= env->head;
1551        env->head= iterator->next;
1552        iterator->next= NULL;
1553    
1554        pack->type= list;
1555        pack->content.ptr= temp;
1556        
1557        if(env->head!=NULL)
1558          toss(env);
1559      }
1560    
1561      /* Push list */
1562    
1563      push_val(env, pack);
1564    
1565      unprotect(env);
1566  }  }
1567    
1568  /* Read a string */  /* Read a string */
1569  extern void readline(environment *env) {  extern void readline(environment *env)
1570    {
1571    char in_string[101];    char in_string[101];
1572    
1573    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1363  extern void readline(environment *env) { Line 1577  extern void readline(environment *env) {
1577  }  }
1578    
1579  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1580  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1581    {
1582    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1583    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1584    const char intform[]= "%i%n";    const char intform[]= "%i%n";
1585      const char fltform[]= "%f%n";
1586    const char blankform[]= "%*[ \t]%n";    const char blankform[]= "%*[ \t]%n";
1587    const char ebrackform[]= "]%n";    const char ebrackform[]= "]%n";
1588    const char semicform[]= ";%n";    const char semicform[]= ";%n";
1589    const char bbrackform[]= "[%n";    const char bbrackform[]= "[%n";
1590    
1591    int itemp, readlength= -1;    int itemp, readlength= -1;
1592      int count= -1;
1593      float ftemp;
1594    static int depth= 0;    static int depth= 0;
1595    char *match;    char *match, *ctemp;
1596    size_t inlength;    size_t inlength;
1597    
1598    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1397  extern void sx_72656164(environment *env Line 1615  extern void sx_72656164(environment *env
1615    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1616    match= malloc(inlength);    match= malloc(inlength);
1617    
1618    if(sscanf(env->in_string, blankform, &readlength)!=EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1619       && readlength != -1) {       && readlength != -1) {
1620      ;      ;
1621    } else if(sscanf(env->in_string, intform, &itemp, &readlength) != EOF    } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
1622              && readlength != -1) {              && readlength != -1) {
1623      push_int(env, itemp);      if(sscanf(env->in_string, intform, &itemp, &count) != EOF
1624           && count==readlength) {
1625          push_int(env, itemp);
1626        } else {
1627          push_float(env, ftemp);
1628        }
1629    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1630              && readlength != -1) {              && readlength != -1) {
1631      push_cstring(env, match);      push_cstring(env, match);
# Line 1424  extern void sx_72656164(environment *env Line 1647  extern void sx_72656164(environment *env
1647      free(env->free_string);      free(env->free_string);
1648      env->in_string = env->free_string = NULL;      env->in_string = env->free_string = NULL;
1649    }    }
1650    if ( env->in_string != NULL) {    if (env->in_string != NULL) {
1651      env->in_string += readlength;      env->in_string += readlength;
1652    }    }
1653    
# Line 1434  extern void sx_72656164(environment *env Line 1657  extern void sx_72656164(environment *env
1657      return sx_72656164(env);      return sx_72656164(env);
1658  }  }
1659    
1660  extern void beep(environment *env) {  extern void beep(environment *env)
1661    {
1662    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1663    
1664    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
# Line 1451  extern void beep(environment *env) { Line 1674  extern void beep(environment *env) {
1674      return;      return;
1675    }    }
1676    
1677    dur=env->head->item->content.val;    dur=env->head->item->content.i;
1678    toss(env);    toss(env);
1679    freq=env->head->item->content.val;    freq=env->head->item->content.i;
1680    toss(env);    toss(env);
1681    
1682    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 1698  extern void beep(environment *env) {
1698    default:    default:
1699      abort();      abort();
1700    }    }
1701  };  }
1702    
1703  /* "wait" */  /* "wait" */
1704  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1705    {
1706    int dur;    int dur;
1707    
1708    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 1494  extern void sx_77616974(environment *env Line 1717  extern void sx_77616974(environment *env
1717      return;      return;
1718    }    }
1719    
1720    dur=env->head->item->content.val;    dur=env->head->item->content.i;
1721    toss(env);    toss(env);
1722    
1723    usleep(dur);    usleep(dur);
1724  };  }
1725    
1726  extern void copying(environment *env){  extern void copying(environment *env)
1727    {
1728    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1729                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1730  \n\  \n\
# Line 1759  of preserving the free status of all der Line 1983  of preserving the free status of all der
1983  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
1984  }  }
1985    
1986  extern void warranty(environment *env){  extern void warranty(environment *env)
1987    {
1988    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
1989  \n\  \n\
1990    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 1787  POSSIBILITY OF SUCH DAMAGES.\n"); Line 2012  POSSIBILITY OF SUCH DAMAGES.\n");
2012  extern void sx_2a(environment *env)  extern void sx_2a(environment *env)
2013  {  {
2014    int a, b;    int a, b;
2015      float fa, fb;
2016    
2017    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
2018      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 1794  extern void sx_2a(environment *env) Line 2020  extern void sx_2a(environment *env)
2020      return;      return;
2021    }    }
2022        
2023    if(env->head->item->type!=integer    if(env->head->item->type==integer
2024       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
2025      printerr("Bad Argument Type");      a=env->head->item->content.i;
2026      env->err=2;      toss(env); if(env->err) return;
2027        b=env->head->item->content.i;
2028        toss(env); if(env->err) return;
2029        push_int(env, b*a);
2030    
2031      return;      return;
2032    }    }
2033    
2034    a=env->head->item->content.val;    if(env->head->item->type==tfloat
2035    toss(env); if(env->err) return;       && env->head->next->item->type==tfloat) {
2036    b=env->head->item->content.val;      fa= env->head->item->content.f;
2037    toss(env); if(env->err) return;      toss(env); if(env->err) return;
2038    push_int(env, b*a);      fb= env->head->item->content.f;
2039        toss(env); if(env->err) return;
2040        push_float(env, fb*fa);
2041        
2042        return;
2043      }
2044    
2045      if(env->head->item->type==tfloat
2046         && env->head->next->item->type==integer) {
2047        fa= env->head->item->content.f;
2048        toss(env); if(env->err) return;
2049        b= env->head->item->content.i;
2050        toss(env); if(env->err) return;
2051        push_float(env, b*fa);
2052        
2053        return;
2054      }
2055    
2056      if(env->head->item->type==integer
2057         && env->head->next->item->type==tfloat) {
2058        a= env->head->item->content.i;
2059        toss(env); if(env->err) return;
2060        fb= env->head->item->content.f;
2061        toss(env); if(env->err) return;
2062        push_float(env, fb*a);
2063    
2064        return;
2065      }
2066    
2067      printerr("Bad Argument Type");
2068      env->err=2;
2069  }  }
2070    
2071  /* "/" */  /* "/" */
2072  extern void sx_2f(environment *env)  extern void sx_2f(environment *env)
2073  {  {
2074    int a, b;    int a, b;
2075      float fa, fb;
2076    
2077    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
2078      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 1819  extern void sx_2f(environment *env) Line 2080  extern void sx_2f(environment *env)
2080      return;      return;
2081    }    }
2082        
2083    if(env->head->item->type!=integer    if(env->head->item->type==integer
2084       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
2085      printerr("Bad Argument Type");      a=env->head->item->content.i;
2086      env->err=2;      toss(env); if(env->err) return;
2087        b=env->head->item->content.i;
2088        toss(env); if(env->err) return;
2089        push_float(env, b/a);
2090    
2091      return;      return;
2092    }    }
2093    
2094    a=env->head->item->content.val;    if(env->head->item->type==tfloat
2095    toss(env); if(env->err) return;       && env->head->next->item->type==tfloat) {
2096    b=env->head->item->content.val;      fa= env->head->item->content.f;
2097    toss(env); if(env->err) return;      toss(env); if(env->err) return;
2098    push_int(env, b/a);      fb= env->head->item->content.f;
2099        toss(env); if(env->err) return;
2100        push_float(env, fb/fa);
2101        
2102        return;
2103      }
2104    
2105      if(env->head->item->type==tfloat
2106         && env->head->next->item->type==integer) {
2107        fa= env->head->item->content.f;
2108        toss(env); if(env->err) return;
2109        b= env->head->item->content.i;
2110        toss(env); if(env->err) return;
2111        push_float(env, b/fa);
2112        
2113        return;
2114      }
2115    
2116      if(env->head->item->type==integer
2117         && env->head->next->item->type==tfloat) {
2118        a= env->head->item->content.i;
2119        toss(env); if(env->err) return;
2120        fb= env->head->item->content.f;
2121        toss(env); if(env->err) return;
2122        push_float(env, fb/a);
2123    
2124        return;
2125      }
2126    
2127      printerr("Bad Argument Type");
2128      env->err=2;
2129  }  }
2130    
2131  /* "mod" */  /* "mod" */
# Line 1840  extern void mod(environment *env) Line 2135  extern void mod(environment *env)
2135    
2136    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
2137      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2138      env->err=1;      env->err= 1;
2139      return;      return;
2140    }    }
2141        
2142    if(env->head->item->type!=integer    if(env->head->item->type==integer
2143       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
2144      printerr("Bad Argument Type");      a= env->head->item->content.i;
2145      env->err=2;      toss(env); if(env->err) return;
2146        b= env->head->item->content.i;
2147        toss(env); if(env->err) return;
2148        push_int(env, b%a);
2149    
2150      return;      return;
2151    }    }
2152    
2153    a=env->head->item->content.val;    printerr("Bad Argument Type");
2154    toss(env); if(env->err) return;    env->err=2;
2155    b=env->head->item->content.val;  }
2156    toss(env); if(env->err) return;  
2157    push_int(env, b%a);  /* "div" */
2158    extern void sx_646976(environment *env)
2159    {
2160      int a, b;
2161      
2162      if((env->head)==NULL || env->head->next==NULL) {
2163        printerr("Too Few Arguments");
2164        env->err= 1;
2165        return;
2166      }
2167    
2168      if(env->head->item->type==integer
2169         && env->head->next->item->type==integer) {
2170        a= env->head->item->content.i;
2171        toss(env); if(env->err) return;
2172        b= env->head->item->content.i;
2173        toss(env); if(env->err) return;
2174        push_int(env, (int)b/a);
2175    
2176        return;
2177      }
2178    
2179      printerr("Bad Argument Type");
2180      env->err= 2;
2181  }  }
Legend:
Removed from v.1.92  
changed lines
  Added in v.1.96
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26