/[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.95 by masse, Sun Mar 10 06:34:01 2002 UTC
# 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      env->gc_limit--;
86    gc_init(env);    gc_init(env);
87  }  }
88    
# Line 113  symbol **hash(hashtbl in_hashtbl, const Line 115  symbol **hash(hashtbl in_hashtbl, const
115    }    }
116  }  }
117    
118  value* new_val(environment *env) {  /* Create new value */
119    value* new_val(environment *env)
120    {
121    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
122    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
123    
124    nval->content.ptr= NULL;    nval->content.ptr= NULL;
   protect(env, nval);  
   
   gc_init(env);  
125    
126    nitem->item= nval;    nitem->item= nval;
127    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
128    env->gc_ref= nitem;    env->gc_ref= nitem;
129    
130    env->gc_count++;    env->gc_count++;
131    
132      protect(env, nval);
133      gc_init(env);
134    unprotect(env);    unprotect(env);
135    
136    return nval;    return nval;
137  }  }
138    
139  void gc_mark(value *val) {  /* Mark values recursively.
140       Marked values are not collected by the GC. */
141    void gc_mark(value *val)
142    {
143    stackitem *iterator;    stackitem *iterator;
144    
145    if(val==NULL || val->gc_garb==0)    if(val==NULL || val->gc_garb==0)
# Line 150  void gc_mark(value *val) { Line 157  void gc_mark(value *val) {
157    }    }
158  }  }
159    
160  extern void gc_init(environment *env) {  /* Start GC */
161    stackitem *new_head= NULL, *titem, *iterator= env->gc_ref;  extern void gc_init(environment *env)
162    {
163      stackitem *new_head= NULL, *titem, *iterator;
164    symbol *tsymb;    symbol *tsymb;
165    int i;    int i;
166    
167    if(env->gc_count < env->gc_limit)    if(env->gc_count < env->gc_limit)
168      return;      return;
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 597  extern void eval(environment *env) Line 640  extern void eval(environment *env)
640    case list:    case list:
641      temp_val= env->head->item;      temp_val= env->head->item;
642      protect(env, temp_val);      protect(env, temp_val);
643      toss(env);  
644      if(env->err) return;      toss(env); if(env->err) return;
645      iterator= (stackitem*)temp_val->content.ptr;      iterator= (stackitem*)temp_val->content.ptr;
     unprotect(env);  
646            
647      while(iterator!=NULL) {      while(iterator!=NULL) {
648        push_val(env, iterator->item);        push_val(env, iterator->item);
# Line 618  extern void eval(environment *env) Line 660  extern void eval(environment *env)
660        }        }
661        iterator= iterator->next;        iterator= iterator->next;
662      }      }
663        unprotect(env);
664      return;      return;
665    
666    default:    default:
# Line 626  extern void eval(environment *env) Line 669  extern void eval(environment *env)
669  }  }
670    
671  /* Reverse (flip) a list */  /* Reverse (flip) a list */
672  extern void rev(environment *env){  extern void rev(environment *env)
673    {
674    stackitem *old_head, *new_head, *item;    stackitem *old_head, *new_head, *item;
675    
676    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 659  extern void pack(environment *env) Line 703  extern void pack(environment *env)
703    value *pack;    value *pack;
704    
705    iterator= env->head;    iterator= env->head;
706      pack= new_val(env);
707      protect(env, pack);
708    
709    if(iterator==NULL    if(iterator==NULL
710       || (iterator->item->type==symb       || (iterator->item->type==symb
# Line 676  extern void pack(environment *env) Line 722  extern void pack(environment *env)
722      temp= env->head;      temp= env->head;
723      env->head= iterator->next;      env->head= iterator->next;
724      iterator->next= NULL;      iterator->next= NULL;
725    
726        pack->type= list;
727        pack->content.ptr= temp;
728            
729      if(env->head!=NULL)      if(env->head!=NULL)
730        toss(env);        toss(env);
731    }    }
732    
733    /* Push list */    /* Push list */
   pack= new_val(env);  
   pack->type= list;  
   pack->content.ptr= temp;  
734    
735    push_val(env, pack);    push_val(env, pack);
736    rev(env);    rev(env);
737    
738      unprotect(env);
739  }  }
740    
741  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
# Line 765  extern void not(environment *env) Line 813  extern void not(environment *env)
813      return;      return;
814    }    }
815    
816    val= env->head->item->content.val;    val= env->head->item->content.i;
817    toss(env);    toss(env);
818    push_int(env, !val);    push_int(env, !val);
819  }  }
# Line 808  extern void def(environment *env) Line 856  extern void def(environment *env)
856  /* Quit stack. */  /* Quit stack. */
857  extern void quit(environment *env)  extern void quit(environment *env)
858  {  {
859    long i;    int i;
860    
861    clear(env);    clear(env);
862    
# Line 854  extern void words(environment *env) Line 902  extern void words(environment *env)
902  }  }
903    
904  /* Internal forget function */  /* Internal forget function */
905  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
906    {
907    symbol *temp;    symbol *temp;
908    
909    temp= *hash_entry;    temp= *hash_entry;
# Line 889  extern void forget(environment *env) Line 938  extern void forget(environment *env)
938  }  }
939    
940  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
941  extern void errn(environment *env){  extern void errn(environment *env)
942    {
943    push_int(env, env->err);    push_int(env, env->err);
944  }  }
945    
# Line 965  under certain conditions; type `copying; Line 1015  under certain conditions; type `copying;
1015  }  }
1016    
1017  /* "+" */  /* "+" */
1018  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1019    {
1020    int a, b;    int a, b;
1021      float fa, fb;
1022    size_t len;    size_t len;
1023    char* new_string;    char* new_string;
1024    value *a_val, *b_val;    value *a_val, *b_val;
# Line 991  extern void sx_2b(environment *env) { Line 1043  extern void sx_2b(environment *env) {
1043      push_cstring(env, new_string);      push_cstring(env, new_string);
1044      unprotect(env); unprotect(env);      unprotect(env); unprotect(env);
1045      free(new_string);      free(new_string);
1046        
1047      return;      return;
1048    }    }
1049        
1050    if(env->head->item->type!=integer    if(env->head->item->type==integer
1051       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
1052      printerr("Bad Argument Type");      a=env->head->item->content.i;
1053      env->err=2;      toss(env); if(env->err) return;
1054        b=env->head->item->content.i;
1055        toss(env); if(env->err) return;
1056        push_int(env, b+a);
1057    
1058      return;      return;
1059    }    }
1060    a= env->head->item->content.val;  
1061    toss(env); if(env->err) return;    if(env->head->item->type==tfloat
1062           && env->head->next->item->type==tfloat) {
1063    b= env->head->item->content.val;      fa= env->head->item->content.f;
1064    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1065    push_int(env, a+b);      fb= env->head->item->content.f;
1066        toss(env); if(env->err) return;
1067        push_float(env, fb+fa);
1068        
1069        return;
1070      }
1071    
1072      if(env->head->item->type==tfloat
1073         && env->head->next->item->type==integer) {
1074        fa= env->head->item->content.f;
1075        toss(env); if(env->err) return;
1076        b= env->head->item->content.i;
1077        toss(env); if(env->err) return;
1078        push_float(env, b+fa);
1079        
1080        return;
1081      }
1082    
1083      if(env->head->item->type==integer
1084         && env->head->next->item->type==tfloat) {
1085        a= env->head->item->content.i;
1086        toss(env); if(env->err) return;
1087        fb= env->head->item->content.f;
1088        toss(env); if(env->err) return;
1089        push_float(env, fb+a);
1090    
1091        return;
1092      }
1093    
1094      printerr("Bad Argument Type");
1095      env->err=2;
1096  }  }
1097    
1098  /* "-" */  /* "-" */
1099  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1100    {
1101    int a, b;    int a, b;
1102      float fa, fb;
1103    
1104    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1105      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 1018  extern void sx_2d(environment *env) { Line 1107  extern void sx_2d(environment *env) {
1107      return;      return;
1108    }    }
1109        
1110    if(env->head->item->type!=integer    if(env->head->item->type==integer
1111       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
1112      printerr("Bad Argument Type");      a=env->head->item->content.i;
1113      env->err=2;      toss(env); if(env->err) return;
1114        b=env->head->item->content.i;
1115        toss(env); if(env->err) return;
1116        push_int(env, b-a);
1117    
1118      return;      return;
1119    }    }
1120    
1121    a=env->head->item->content.val;    if(env->head->item->type==tfloat
1122    toss(env); if(env->err) return;       && env->head->next->item->type==tfloat) {
1123    b=env->head->item->content.val;      fa= env->head->item->content.f;
1124    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1125    push_int(env, b-a);      fb= env->head->item->content.f;
1126        toss(env); if(env->err) return;
1127        push_float(env, fb-fa);
1128        
1129        return;
1130      }
1131    
1132      if(env->head->item->type==tfloat
1133         && env->head->next->item->type==integer) {
1134        fa= env->head->item->content.f;
1135        toss(env); if(env->err) return;
1136        b= env->head->item->content.i;
1137        toss(env); if(env->err) return;
1138        push_float(env, b-fa);
1139        
1140        return;
1141      }
1142    
1143      if(env->head->item->type==integer
1144         && env->head->next->item->type==tfloat) {
1145        a= env->head->item->content.i;
1146        toss(env); if(env->err) return;
1147        fb= env->head->item->content.f;
1148        toss(env); if(env->err) return;
1149        push_float(env, fb-a);
1150    
1151        return;
1152      }
1153    
1154      printerr("Bad Argument Type");
1155      env->err=2;
1156  }  }
1157    
1158  /* ">" */  /* ">" */
1159  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1160    {
1161    int a, b;    int a, b;
1162      float fa, fb;
1163    
1164    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1165      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 1042  extern void sx_3e(environment *env) { Line 1167  extern void sx_3e(environment *env) {
1167      return;      return;
1168    }    }
1169        
1170    if(env->head->item->type!=integer    if(env->head->item->type==integer
1171       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
1172      printerr("Bad Argument Type");      a=env->head->item->content.i;
1173      env->err=2;      toss(env); if(env->err) return;
1174        b=env->head->item->content.i;
1175        toss(env); if(env->err) return;
1176        push_int(env, b>a);
1177    
1178      return;      return;
1179    }    }
1180    
1181    a=env->head->item->content.val;    if(env->head->item->type==tfloat
1182    toss(env); if(env->err) return;       && env->head->next->item->type==tfloat) {
1183    b=env->head->item->content.val;      fa= env->head->item->content.f;
1184    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1185    push_int(env, b>a);      fb= env->head->item->content.f;
1186        toss(env); if(env->err) return;
1187        push_int(env, fb>fa);
1188        
1189        return;
1190      }
1191    
1192      if(env->head->item->type==tfloat
1193         && env->head->next->item->type==integer) {
1194        fa= env->head->item->content.f;
1195        toss(env); if(env->err) return;
1196        b= env->head->item->content.i;
1197        toss(env); if(env->err) return;
1198        push_int(env, b>fa);
1199        
1200        return;
1201      }
1202    
1203      if(env->head->item->type==integer
1204         && env->head->next->item->type==tfloat) {
1205        a= env->head->item->content.i;
1206        toss(env); if(env->err) return;
1207        fb= env->head->item->content.f;
1208        toss(env); if(env->err) return;
1209        push_int(env, fb>a);
1210    
1211        return;
1212      }
1213    
1214      printerr("Bad Argument Type");
1215      env->err=2;
1216    }
1217    
1218    /* "<" */
1219    extern void sx_3c(environment *env)
1220    {
1221      swap(env); if(env->err) return;
1222      sx_3e(env);
1223    }
1224    
1225    /* "<=" */
1226    extern void sx_3c3d(environment *env)
1227    {
1228      sx_3e(env); if(env->err) return;
1229      not(env);
1230    }
1231    
1232    /* ">=" */
1233    extern void sx_3e3d(environment *env)
1234    {
1235      sx_3c(env); if(env->err) return;
1236      not(env);
1237  }  }
1238    
1239  /* Return copy of a value */  /* Return copy of a value */
1240  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1241    {
1242    stackitem *old_item, *new_item, *prev_item;    stackitem *old_item, *new_item, *prev_item;
1243      value *new_value;
   value *new_value= new_val(env);  
1244    
1245    protect(env, old_value);    protect(env, old_value);
1246      new_value= new_val(env);
1247      protect(env, new_value);
1248    new_value->type= old_value->type;    new_value->type= old_value->type;
1249    
1250    switch(old_value->type){    switch(old_value->type){
1251      case tfloat:
1252    case integer:    case integer:
1253      new_value->content.val= old_value->content.val;    case func:
1254      case symb:
1255        new_value->content= old_value->content;
1256      break;      break;
1257    case string:    case string:
1258      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1259        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1260      break;      break;
   case func:  
   case symb:  
     new_value->content.ptr= old_value->content.ptr;  
     break;  
1261    case list:    case list:
1262      new_value->content.ptr= NULL;      new_value->content.ptr= NULL;
1263    
# Line 1098  value *copy_val(environment *env, value Line 1279  value *copy_val(environment *env, value
1279      break;      break;
1280    }    }
1281    
1282    unprotect(env);    unprotect(env); unprotect(env);
1283    
1284    return new_value;    return new_value;
1285  }  }
1286    
1287  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1288  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1289    {
1290    if((env->head)==NULL) {    if((env->head)==NULL) {
1291      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1292      env->err= 1;      env->err= 1;
# Line 1114  extern void sx_647570(environment *env) Line 1296  extern void sx_647570(environment *env)
1296  }  }
1297    
1298  /* "if", If-Then */  /* "if", If-Then */
1299  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1300    {
1301    int truth;    int truth;
1302    
1303    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 1315  extern void sx_6966(environment *env) {
1315    swap(env);    swap(env);
1316    if(env->err) return;    if(env->err) return;
1317        
1318    truth=env->head->item->content.val;    truth=env->head->item->content.i;
1319    
1320    toss(env);    toss(env);
1321    if(env->err) return;    if(env->err) return;
# Line 1145  extern void sx_6966(environment *env) { Line 1327  extern void sx_6966(environment *env) {
1327  }  }
1328    
1329  /* If-Then-Else */  /* If-Then-Else */
1330  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1331    {
1332    int truth;    int truth;
1333    
1334    if((env->head)==NULL || env->head->next==NULL    if((env->head)==NULL || env->head->next==NULL
# Line 1165  extern void ifelse(environment *env) { Line 1347  extern void ifelse(environment *env) {
1347    rot(env);    rot(env);
1348    if(env->err) return;    if(env->err) return;
1349        
1350    truth=env->head->item->content.val;    truth=env->head->item->content.i;
1351    
1352    toss(env);    toss(env);
1353    if(env->err) return;    if(env->err) return;
# Line 1181  extern void ifelse(environment *env) { Line 1363  extern void ifelse(environment *env) {
1363  }  }
1364    
1365  /* "while" */  /* "while" */
1366  extern void sx_7768696c65(environment *env) {  extern void sx_7768696c65(environment *env)
1367    {
1368    int truth;    int truth;
1369    value *loop, *test;    value *loop, *test;
1370    
# Line 1210  extern void sx_7768696c65(environment *e Line 1392  extern void sx_7768696c65(environment *e
1392        return;        return;
1393      }      }
1394            
1395      truth= env->head->item->content.val;      truth= env->head->item->content.i;
1396      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1397            
1398      if(truth) {      if(truth) {
# Line 1227  extern void sx_7768696c65(environment *e Line 1409  extern void sx_7768696c65(environment *e
1409    
1410    
1411  /* "for"; for-loop */  /* "for"; for-loop */
1412  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1413    {
1414    value *loop;    value *loop;
1415    int foo1, foo2;    int foo1, foo2;
1416    
# Line 1249  extern void sx_666f72(environment *env) Line 1432  extern void sx_666f72(environment *env)
1432    protect(env, loop);    protect(env, loop);
1433    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1434    
1435    foo2= env->head->item->content.val;    foo2= env->head->item->content.i;
1436    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1437    
1438    foo1= env->head->item->content.val;    foo1= env->head->item->content.i;
1439    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1440    
1441    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1274  extern void sx_666f72(environment *env) Line 1457  extern void sx_666f72(environment *env)
1457  }  }
1458    
1459  /* Variant of for-loop */  /* Variant of for-loop */
1460  extern void foreach(environment *env) {  extern void foreach(environment *env)
1461      {  
1462    value *loop, *foo;    value *loop, *foo;
1463    stackitem *iterator;    stackitem *iterator;
1464        
# Line 1311  extern void foreach(environment *env) { Line 1494  extern void foreach(environment *env) {
1494  }  }
1495    
1496  /* "to" */  /* "to" */
1497  extern void to(environment *env) {  extern void to(environment *env)
1498    int i, start, ending;  {
1499    stackitem *temp_head;    int ending, start, i;
1500    value *temp_val;    stackitem *iterator, *temp;
1501        value *pack;
1502    
1503    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1504      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1505      env->err=1;      env->err=1;
# Line 1329  extern void to(environment *env) { Line 1513  extern void to(environment *env) {
1513      return;      return;
1514    }    }
1515    
1516    ending= env->head->item->content.val;    ending= env->head->item->content.i;
1517    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1518    start= env->head->item->content.val;    start= env->head->item->content.i;
1519    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1520    
1521    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1522    
1523    if(ending>=start) {    if(ending>=start) {
1524      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1345  extern void to(environment *env) { Line 1528  extern void to(environment *env) {
1528        push_int(env, i);        push_int(env, i);
1529    }    }
1530    
1531    temp_val= new_val(env);    iterator= env->head;
1532    temp_val->content.ptr= env->head;    pack= new_val(env);
1533    temp_val->type= list;    protect(env, pack);
1534    env->head= temp_head;  
1535    push_val(env, temp_val);    if(iterator==NULL
1536         || (iterator->item->type==symb
1537         && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {
1538        temp= NULL;
1539        toss(env);
1540      } else {
1541        /* Search for first delimiter */
1542        while(iterator->next!=NULL
1543              && (iterator->next->item->type!=symb
1544              || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))
1545          iterator= iterator->next;
1546        
1547        /* Extract list */
1548        temp= env->head;
1549        env->head= iterator->next;
1550        iterator->next= NULL;
1551    
1552        pack->type= list;
1553        pack->content.ptr= temp;
1554        
1555        if(env->head!=NULL)
1556          toss(env);
1557      }
1558    
1559      /* Push list */
1560    
1561      push_val(env, pack);
1562    
1563      unprotect(env);
1564  }  }
1565    
1566  /* Read a string */  /* Read a string */
1567  extern void readline(environment *env) {  extern void readline(environment *env)
1568    {
1569    char in_string[101];    char in_string[101];
1570    
1571    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1363  extern void readline(environment *env) { Line 1575  extern void readline(environment *env) {
1575  }  }
1576    
1577  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1578  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1579    {
1580    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1581    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1582    const char intform[]= "%i%n";    const char intform[]= "%i%n";
1583      const char fltform[]= "%f%n";
1584    const char blankform[]= "%*[ \t]%n";    const char blankform[]= "%*[ \t]%n";
1585    const char ebrackform[]= "]%n";    const char ebrackform[]= "]%n";
1586    const char semicform[]= ";%n";    const char semicform[]= ";%n";
1587    const char bbrackform[]= "[%n";    const char bbrackform[]= "[%n";
1588    
1589    int itemp, readlength= -1;    int itemp, readlength= -1;
1590      int count= -1;
1591      float ftemp;
1592    static int depth= 0;    static int depth= 0;
1593    char *match;    char *match, *ctemp;
1594    size_t inlength;    size_t inlength;
1595    
1596    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1397  extern void sx_72656164(environment *env Line 1613  extern void sx_72656164(environment *env
1613    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1614    match= malloc(inlength);    match= malloc(inlength);
1615    
1616    if(sscanf(env->in_string, blankform, &readlength)!=EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1617       && readlength != -1) {       && readlength != -1) {
1618      ;      ;
1619    } else if(sscanf(env->in_string, intform, &itemp, &readlength) != EOF    } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
1620              && readlength != -1) {              && readlength != -1) {
1621      push_int(env, itemp);      if(sscanf(env->in_string, intform, &itemp, &count) != EOF
1622           && count==readlength) {
1623          push_int(env, itemp);
1624        } else {
1625          push_float(env, ftemp);
1626        }
1627    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1628              && readlength != -1) {              && readlength != -1) {
1629      push_cstring(env, match);      push_cstring(env, match);
# Line 1424  extern void sx_72656164(environment *env Line 1645  extern void sx_72656164(environment *env
1645      free(env->free_string);      free(env->free_string);
1646      env->in_string = env->free_string = NULL;      env->in_string = env->free_string = NULL;
1647    }    }
1648    if ( env->in_string != NULL) {    if (env->in_string != NULL) {
1649      env->in_string += readlength;      env->in_string += readlength;
1650    }    }
1651    
# Line 1434  extern void sx_72656164(environment *env Line 1655  extern void sx_72656164(environment *env
1655      return sx_72656164(env);      return sx_72656164(env);
1656  }  }
1657    
1658  extern void beep(environment *env) {  extern void beep(environment *env)
1659    {
1660    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1661    
1662    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
# Line 1451  extern void beep(environment *env) { Line 1672  extern void beep(environment *env) {
1672      return;      return;
1673    }    }
1674    
1675    dur=env->head->item->content.val;    dur=env->head->item->content.i;
1676    toss(env);    toss(env);
1677    freq=env->head->item->content.val;    freq=env->head->item->content.i;
1678    toss(env);    toss(env);
1679    
1680    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 1696  extern void beep(environment *env) {
1696    default:    default:
1697      abort();      abort();
1698    }    }
1699  };  }
1700    
1701  /* "wait" */  /* "wait" */
1702  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1703    {
1704    int dur;    int dur;
1705    
1706    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 1494  extern void sx_77616974(environment *env Line 1715  extern void sx_77616974(environment *env
1715      return;      return;
1716    }    }
1717    
1718    dur=env->head->item->content.val;    dur=env->head->item->content.i;
1719    toss(env);    toss(env);
1720    
1721    usleep(dur);    usleep(dur);
1722  };  }
1723    
1724  extern void copying(environment *env){  extern void copying(environment *env)
1725    {
1726    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1727                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1728  \n\  \n\
# Line 1759  of preserving the free status of all der Line 1981  of preserving the free status of all der
1981  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
1982  }  }
1983    
1984  extern void warranty(environment *env){  extern void warranty(environment *env)
1985    {
1986    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
1987  \n\  \n\
1988    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 2005  YOU OR THIRD PARTIES OR A FAILURE OF THE
2005  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\
2006  POSSIBILITY OF SUCH DAMAGES.\n");  POSSIBILITY OF SUCH DAMAGES.\n");
2007  }  }
2008    
2009    /* "*" */
2010    extern void sx_2a(environment *env)
2011    {
2012      int a, b;
2013      float fa, fb;
2014    
2015      if((env->head)==NULL || env->head->next==NULL) {
2016        printerr("Too Few Arguments");
2017        env->err=1;
2018        return;
2019      }
2020      
2021      if(env->head->item->type==integer
2022         && env->head->next->item->type==integer) {
2023        a=env->head->item->content.i;
2024        toss(env); if(env->err) return;
2025        b=env->head->item->content.i;
2026        toss(env); if(env->err) return;
2027        push_int(env, b*a);
2028    
2029        return;
2030      }
2031    
2032      if(env->head->item->type==tfloat
2033         && env->head->next->item->type==tfloat) {
2034        fa= env->head->item->content.f;
2035        toss(env); if(env->err) return;
2036        fb= env->head->item->content.f;
2037        toss(env); if(env->err) return;
2038        push_float(env, fb*fa);
2039        
2040        return;
2041      }
2042    
2043      if(env->head->item->type==tfloat
2044         && env->head->next->item->type==integer) {
2045        fa= env->head->item->content.f;
2046        toss(env); if(env->err) return;
2047        b= env->head->item->content.i;
2048        toss(env); if(env->err) return;
2049        push_float(env, b*fa);
2050        
2051        return;
2052      }
2053    
2054      if(env->head->item->type==integer
2055         && env->head->next->item->type==tfloat) {
2056        a= env->head->item->content.i;
2057        toss(env); if(env->err) return;
2058        fb= env->head->item->content.f;
2059        toss(env); if(env->err) return;
2060        push_float(env, fb*a);
2061    
2062        return;
2063      }
2064    
2065      printerr("Bad Argument Type");
2066      env->err=2;
2067    }
2068    
2069    /* "/" */
2070    extern void sx_2f(environment *env)
2071    {
2072      int a, b;
2073      float fa, fb;
2074    
2075      if((env->head)==NULL || env->head->next==NULL) {
2076        printerr("Too Few Arguments");
2077        env->err=1;
2078        return;
2079      }
2080      
2081      if(env->head->item->type==integer
2082         && env->head->next->item->type==integer) {
2083        a=env->head->item->content.i;
2084        toss(env); if(env->err) return;
2085        b=env->head->item->content.i;
2086        toss(env); if(env->err) return;
2087        push_float(env, b/a);
2088    
2089        return;
2090      }
2091    
2092      if(env->head->item->type==tfloat
2093         && env->head->next->item->type==tfloat) {
2094        fa= env->head->item->content.f;
2095        toss(env); if(env->err) return;
2096        fb= env->head->item->content.f;
2097        toss(env); if(env->err) return;
2098        push_float(env, fb/fa);
2099        
2100        return;
2101      }
2102    
2103      if(env->head->item->type==tfloat
2104         && env->head->next->item->type==integer) {
2105        fa= env->head->item->content.f;
2106        toss(env); if(env->err) return;
2107        b= env->head->item->content.i;
2108        toss(env); if(env->err) return;
2109        push_float(env, b/fa);
2110        
2111        return;
2112      }
2113    
2114      if(env->head->item->type==integer
2115         && env->head->next->item->type==tfloat) {
2116        a= env->head->item->content.i;
2117        toss(env); if(env->err) return;
2118        fb= env->head->item->content.f;
2119        toss(env); if(env->err) return;
2120        push_float(env, fb/a);
2121    
2122        return;
2123      }
2124    
2125      printerr("Bad Argument Type");
2126      env->err=2;
2127    }
2128    
2129    /* "mod" */
2130    extern void mod(environment *env)
2131    {
2132      int a, b;
2133    
2134      if((env->head)==NULL || env->head->next==NULL) {
2135        printerr("Too Few Arguments");
2136        env->err= 1;
2137        return;
2138      }
2139      
2140      if(env->head->item->type==integer
2141         && env->head->next->item->type==integer) {
2142        a= env->head->item->content.i;
2143        toss(env); if(env->err) return;
2144        b= env->head->item->content.i;
2145        toss(env); if(env->err) return;
2146        push_int(env, b%a);
2147    
2148        return;
2149      }
2150    
2151      printerr("Bad Argument Type");
2152      env->err=2;
2153    }
2154    
2155    /* "div" */
2156    extern void sx_646976(environment *env)
2157    {
2158      int a, b;
2159      
2160      if((env->head)==NULL || env->head->next==NULL) {
2161        printerr("Too Few Arguments");
2162        env->err= 1;
2163        return;
2164      }
2165    
2166      if(env->head->item->type==integer
2167         && env->head->next->item->type==integer) {
2168        a= env->head->item->content.i;
2169        toss(env); if(env->err) return;
2170        b= env->head->item->content.i;
2171        toss(env); if(env->err) return;
2172        push_int(env, (int)b/a);
2173    
2174        return;
2175      }
2176    
2177      printerr("Bad Argument Type");
2178      env->err= 2;
2179    }
Legend:
Removed from v.1.91  
changed lines
  Added in v.1.95
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26