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

Diff of /stack/stack.c

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

revision 1.94 by masse, Sat Mar 9 09:58:31 2002 UTC revision 1.99 by teddy, Sun Mar 10 10:06:36 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;
   env->gc_protect= NULL;  
54    
55    env->head= NULL;    env->head= NULL;
56    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
# Line 63  void init_env(environment *env) Line 62  void init_env(environment *env)
62    env->interactive= 1;    env->interactive= 1;
63  }  }
64    
65  void printerr(const char* in_string) {  void printerr(const char* in_string)
66    {
67    fprintf(stderr, "Err: %s\n", in_string);    fprintf(stderr, "Err: %s\n", in_string);
68  }  }
69    
# Line 81  extern void toss(environment *env) Line 81  extern void toss(environment *env)
81    env->head= env->head->next;   /* Remove the top stack item */    env->head= env->head->next;   /* Remove the top stack item */
82    free(temp);                   /* Free the old top stack item */    free(temp);                   /* Free the old top stack item */
83    
84    gc_init(env);    env->gc_limit--;
85  }  }
86    
87  /* 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 113  symbol **hash(hashtbl in_hashtbl, const
113    }    }
114  }  }
115    
116  value* new_val(environment *env) {  /* Create new value */
117    value* new_val(environment *env)
118    {
119    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
120    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
121    
# Line 124  value* new_val(environment *env) { Line 126  value* new_val(environment *env) {
126    env->gc_ref= nitem;    env->gc_ref= nitem;
127    
128    env->gc_count++;    env->gc_count++;
129      nval->gc.flag.mark= 0;
130    protect(env, nval);    nval->gc.flag.protect= 0;
   gc_init(env);  
   unprotect(env);  
131    
132    return nval;    return nval;
133  }  }
134    
135  void gc_mark(value *val) {  /* Mark values recursively.
136       Marked values are not collected by the GC. */
137    inline void gc_mark(value *val)
138    {
139    stackitem *iterator;    stackitem *iterator;
140    
141    if(val==NULL || val->gc_garb==0)    if(val->gc.flag.mark)
142      return;      return;
143    
144    val->gc_garb= 0;    val->gc.flag.mark= 1;
145    
146    if(val->type==list) {    if(val->type==list) {
147      iterator= val->content.ptr;      iterator= val->content.ptr;
# Line 150  void gc_mark(value *val) { Line 153  void gc_mark(value *val) {
153    }    }
154  }  }
155    
156  extern void gc_init(environment *env) {  inline void gc_maybe(environment *env)
157    stackitem *new_head= NULL, *titem, *iterator;  {
   symbol *tsymb;  
   int i;  
   
158    if(env->gc_count < env->gc_limit)    if(env->gc_count < env->gc_limit)
159      return;      return;
160      else
161        return gc_init(env);
162    }
163    
164    /* Garb by default */  /* Start GC */
165    iterator= env->gc_ref;  extern void gc_init(environment *env)
166    while(iterator!=NULL) {  {
167      iterator->item->gc_garb= 1;    stackitem *new_head= NULL, *titem, *iterator;
168      iterator= iterator->next;    symbol *tsymb;
169    }    int i;
   
   /* Mark protected values */  
   iterator= env->gc_protect;  
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
170    
171    /* Mark values in stack */    /* Mark values on stack */
172    iterator= env->head;    iterator= env->head;
173    while(iterator!=NULL) {    while(iterator!=NULL) {
174      gc_mark(iterator->item);      gc_mark(iterator->item);
# Line 183  extern void gc_init(environment *env) { Line 179  extern void gc_init(environment *env) {
179    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
180      tsymb= env->symbols[i];      tsymb= env->symbols[i];
181      while(tsymb!=NULL) {      while(tsymb!=NULL) {
182        gc_mark(tsymb->val);        if (tsymb->val != NULL)
183            gc_mark(tsymb->val);
184        tsymb= tsymb->next;        tsymb= tsymb->next;
185      }      }
186    }    }
187    
188    env->gc_count= 0;    env->gc_count= 0;
189    
190    /* Sweep */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
   while(env->gc_ref!=NULL) {  
191    
192      if(env->gc_ref->item->gc_garb) {      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
193    
194        /* Remove content */        switch(env->gc_ref->item->type) { /* Remove content */
       switch(env->gc_ref->item->type) {  
195        case string:        case string:
196          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
197          break;          break;
# Line 206  extern void gc_init(environment *env) { Line 201  extern void gc_init(environment *env) {
201            env->gc_ref->item->content.ptr= titem->next;            env->gc_ref->item->content.ptr= titem->next;
202            free(titem);            free(titem);
203          }          }
         break;  
204        default:        default:
         break;  
205        }        }
206        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
207        titem= env->gc_ref->next;        titem= env->gc_ref->next;
208        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
209        env->gc_ref= titem;        env->gc_ref= titem;
210      } else {                    /* Save */        continue;
       titem= env->gc_ref->next;  
       env->gc_ref->next= new_head;  
       new_head= env->gc_ref;  
       env->gc_ref= titem;  
       env->gc_count++;  
211      }      }
212        
213        /* Keep values */
214        titem= env->gc_ref->next;
215        env->gc_ref->next= new_head;
216        new_head= env->gc_ref;
217        new_head->item->gc.flag.mark= 0;
218        env->gc_ref= titem;
219        env->gc_count++;
220    }    }
221    
222    env->gc_limit= env->gc_count*2;    env->gc_limit= env->gc_count*2;
223    env->gc_ref= new_head;    env->gc_ref= new_head;
224  }  }
225    
226  void protect(environment *env, value *val)  /* Protect values from GC */
227    void protect(value *val)
228  {  {
229    stackitem *new_item= malloc(sizeof(stackitem));    stackitem *iterator;
230    new_item->item= val;  
231    new_item->next= env->gc_protect;    if(val->gc.flag.protect)
232    env->gc_protect= new_item;      return;
233    
234      val->gc.flag.protect= 1;
235    
236      if(val->type==list) {
237        iterator= val->content.ptr;
238    
239        while(iterator!=NULL) {
240          protect(iterator->item);
241          iterator= iterator->next;
242        }
243      }
244  }  }
245    
246  void unprotect(environment *env)  /* Unprotect values from GC */
247    void unprotect(value *val)
248  {  {
249    stackitem *temp= env->gc_protect;    stackitem *iterator;
250    env->gc_protect= env->gc_protect->next;  
251    free(temp);    if(!(val->gc.flag.protect))
252        return;
253    
254      val->gc.flag.protect= 0;
255    
256      if(val->type==list) {
257        iterator= val->content.ptr;
258    
259        while(iterator!=NULL) {
260          unprotect(iterator->item);
261          iterator= iterator->next;
262        }
263      }
264  }  }
265    
266  /* Push a value onto the stack */  /* Push a value onto the stack */
# Line 251  void push_val(environment *env, value *v Line 272  void push_val(environment *env, value *v
272    env->head= new_item;    env->head= new_item;
273  }  }
274    
275  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
276  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
277  {  {
278    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 262  void push_int(environment *env, int in_v Line 283  void push_int(environment *env, int in_v
283    push_val(env, new_value);    push_val(env, new_value);
284  }  }
285    
286    /* Push a floating point number onto the stack */
287  void push_float(environment *env, float in_val)  void push_float(environment *env, float in_val)
288  {  {
289    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 285  void push_cstring(environment *env, cons Line 307  void push_cstring(environment *env, cons
307  }  }
308    
309  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
310  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
311    {
312    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
313    char *new_string, *current;    char *new_string, *current;
314    
# Line 303  char *mangle_str(const char *old_string) Line 326  char *mangle_str(const char *old_string)
326    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
327  }  }
328    
329  extern void mangle(environment *env){  extern void mangle(environment *env)
330    {
331    char *new_string;    char *new_string;
332    
333    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 342  void push_sym(environment *env, const ch Line 366  void push_sym(environment *env, const ch
366    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
367    
368    new_value= new_val(env);    new_value= new_val(env);
369    protect(env, new_value);    protect(new_value);
370    new_fvalue= new_val(env);    new_fvalue= new_val(env);
371    protect(env, new_fvalue);    protect(new_fvalue);
372    
373    /* The new value is a symbol */    /* The new value is a symbol */
374    new_value->type= symb;    new_value->type= symb;
# Line 372  void push_sym(environment *env, const ch Line 396  void push_sym(environment *env, const ch
396    
397      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
398      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
399      free(mangled);  
400      dlerr= dlerror();      dlerr= dlerror();
401      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
402        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
403        dlerr= dlerror();        dlerr= dlerror();
404      }      }
405    
406      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
407        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
408        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
409        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
410                                           function value */                                           function value */
411      }      }
412    
413        free(mangled);
414    }    }
415    
416    push_val(env, new_value);    push_val(env, new_value);
417    unprotect(env); unprotect(env);    unprotect(new_value); unprotect(new_fvalue);
418  }  }
419    
420  /* Print newline. */  /* Print newline. */
# Line 396  extern void nl() Line 424  extern void nl()
424  }  }
425    
426  /* Gets the type of a value */  /* Gets the type of a value */
427  extern void type(environment *env){  extern void type(environment *env)
428    {
429    int typenum;    int typenum;
430    
431    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 464  void print_h(stackitem *stack_head, int Line 493  void print_h(stackitem *stack_head, int
493    }    }
494  }  }
495    
496  extern void print_(environment *env) {  extern void print_(environment *env)
497    {
498    if(env->head==NULL) {    if(env->head==NULL) {
499      printerr("Too Few Arguments");      printerr("Too Few Arguments");
500      env->err=1;      env->err=1;
# Line 482  extern void print(environment *env) Line 512  extern void print(environment *env)
512    toss(env);    toss(env);
513  }  }
514    
515  extern void princ_(environment *env) {  extern void princ_(environment *env)
516    {
517    if(env->head==NULL) {    if(env->head==NULL) {
518      printerr("Too Few Arguments");      printerr("Too Few Arguments");
519      env->err=1;      env->err=1;
# Line 516  extern void printstack(environment *env) Line 547  extern void printstack(environment *env)
547      printf("Stack Empty\n");      printf("Stack Empty\n");
548      return;      return;
549    }    }
550    
551    print_st(env->head, 1);    print_st(env->head, 1);
552  }  }
553    
# Line 575  extern void rcl(environment *env) Line 607  extern void rcl(environment *env)
607      env->err=3;      env->err=3;
608      return;      return;
609    }    }
610    protect(env, val);    protect(val);
611    toss(env);            /* toss the symbol */    toss(env);            /* toss the symbol */
612    if(env->err) return;    if(env->err) return;
613    push_val(env, val); /* Return its bound value */    push_val(env, val); /* Return its bound value */
614    unprotect(env);    unprotect(val);
615  }  }
616    
617  /* If the top element is a symbol, determine if it's bound to a  /* If the top element is a symbol, determine if it's bound to a
# Line 593  extern void eval(environment *env) Line 625  extern void eval(environment *env)
625    
626   eval_start:   eval_start:
627    
628      gc_maybe(env);
629    
630    if(env->head==NULL) {    if(env->head==NULL) {
631      printerr("Too Few Arguments");      printerr("Too Few Arguments");
632      env->err=1;      env->err=1;
# Line 619  extern void eval(environment *env) Line 653  extern void eval(environment *env)
653      /* If it's a list */      /* If it's a list */
654    case list:    case list:
655      temp_val= env->head->item;      temp_val= env->head->item;
656      protect(env, temp_val);      protect(temp_val);
657    
658      toss(env); if(env->err) return;      toss(env); if(env->err) return;
659      iterator= (stackitem*)temp_val->content.ptr;      iterator= (stackitem*)temp_val->content.ptr;
# Line 640  extern void eval(environment *env) Line 674  extern void eval(environment *env)
674        }        }
675        iterator= iterator->next;        iterator= iterator->next;
676      }      }
677      unprotect(env);      unprotect(temp_val);
678      return;      return;
679    
680    default:    default:
# Line 649  extern void eval(environment *env) Line 683  extern void eval(environment *env)
683  }  }
684    
685  /* Reverse (flip) a list */  /* Reverse (flip) a list */
686  extern void rev(environment *env){  extern void rev(environment *env)
687    {
688    stackitem *old_head, *new_head, *item;    stackitem *old_head, *new_head, *item;
689    
690    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 683  extern void pack(environment *env) Line 718  extern void pack(environment *env)
718    
719    iterator= env->head;    iterator= env->head;
720    pack= new_val(env);    pack= new_val(env);
721    protect(env, pack);    protect(pack);
722    
723    if(iterator==NULL    if(iterator==NULL
724       || (iterator->item->type==symb       || (iterator->item->type==symb
# Line 714  extern void pack(environment *env) Line 749  extern void pack(environment *env)
749    push_val(env, pack);    push_val(env, pack);
750    rev(env);    rev(env);
751    
752    unprotect(env);    unprotect(pack);
753  }  }
754    
755  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
# Line 835  extern void def(environment *env) Line 870  extern void def(environment *env)
870  /* Quit stack. */  /* Quit stack. */
871  extern void quit(environment *env)  extern void quit(environment *env)
872  {  {
873    long i;    int i;
874    
875    clear(env);    clear(env);
876    
# Line 848  extern void quit(environment *env) Line 883  extern void quit(environment *env)
883    }    }
884    
885    env->gc_limit= 0;    env->gc_limit= 0;
886    gc_init(env);    gc_maybe(env);
887    
888    if(env->free_string!=NULL)    if(env->free_string!=NULL)
889      free(env->free_string);      free(env->free_string);
# Line 881  extern void words(environment *env) Line 916  extern void words(environment *env)
916  }  }
917    
918  /* Internal forget function */  /* Internal forget function */
919  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
920    {
921    symbol *temp;    symbol *temp;
922    
923    temp= *hash_entry;    temp= *hash_entry;
# Line 916  extern void forget(environment *env) Line 952  extern void forget(environment *env)
952  }  }
953    
954  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
955  extern void errn(environment *env){  extern void errn(environment *env)
956    {
957    push_int(env, env->err);    push_int(env, env->err);
958  }  }
959    
# Line 985  under certain conditions; type `copying; Line 1022  under certain conditions; type `copying;
1022        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1023        eval(&myenv);        eval(&myenv);
1024      }      }
1025      gc_init(&myenv);      gc_maybe(&myenv);
1026    }    }
1027    quit(&myenv);    quit(&myenv);
1028    return EXIT_FAILURE;    return EXIT_FAILURE;
1029  }  }
1030    
1031  /* "+" */  /* "+" */
1032  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1033    {
1034    int a, b;    int a, b;
1035    float fa, fb;    float fa, fb;
1036    size_t len;    size_t len;
# Line 1009  extern void sx_2b(environment *env) { Line 1047  extern void sx_2b(environment *env) {
1047       && env->head->next->item->type==string) {       && env->head->next->item->type==string) {
1048      a_val= env->head->item;      a_val= env->head->item;
1049      b_val= env->head->next->item;      b_val= env->head->next->item;
1050      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1051      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1052      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1053      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
# Line 1017  extern void sx_2b(environment *env) { Line 1055  extern void sx_2b(environment *env) {
1055      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1056      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1057      push_cstring(env, new_string);      push_cstring(env, new_string);
1058      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1059      free(new_string);      free(new_string);
1060            
1061      return;      return;
# Line 1072  extern void sx_2b(environment *env) { Line 1110  extern void sx_2b(environment *env) {
1110  }  }
1111    
1112  /* "-" */  /* "-" */
1113  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1114    {
1115    int a, b;    int a, b;
1116    float fa, fb;    float fa, fb;
1117    
# Line 1131  extern void sx_2d(environment *env) { Line 1170  extern void sx_2d(environment *env) {
1170  }  }
1171    
1172  /* ">" */  /* ">" */
1173  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1174    {
1175    int a, b;    int a, b;
1176    float fa, fb;    float fa, fb;
1177    
# Line 1190  extern void sx_3e(environment *env) { Line 1230  extern void sx_3e(environment *env) {
1230  }  }
1231    
1232  /* "<" */  /* "<" */
1233  extern void sx_3c(environment *env) {  extern void sx_3c(environment *env)
1234    {
1235    swap(env); if(env->err) return;    swap(env); if(env->err) return;
1236    sx_3e(env);    sx_3e(env);
1237  }  }
1238    
1239  /* "<=" */  /* "<=" */
1240  extern void sx_3c3d(environment *env) {  extern void sx_3c3d(environment *env)
1241    {
1242    sx_3e(env); if(env->err) return;    sx_3e(env); if(env->err) return;
1243    not(env);    not(env);
1244  }  }
1245    
1246  /* ">=" */  /* ">=" */
1247  extern void sx_3e3d(environment *env) {  extern void sx_3e3d(environment *env)
1248    {
1249    sx_3c(env); if(env->err) return;    sx_3c(env); if(env->err) return;
1250    not(env);    not(env);
1251  }  }
1252    
1253  /* Return copy of a value */  /* Return copy of a value */
1254  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1255    {
1256    stackitem *old_item, *new_item, *prev_item;    stackitem *old_item, *new_item, *prev_item;
1257    value *new_value;    value *new_value;
1258    
1259    protect(env, old_value);    protect(old_value);
1260    new_value= new_val(env);    new_value= new_val(env);
1261    protect(env, new_value);    protect(new_value);
1262    new_value->type= old_value->type;    new_value->type= old_value->type;
1263    
1264    switch(old_value->type){    switch(old_value->type){
# Line 1249  value *copy_val(environment *env, value Line 1293  value *copy_val(environment *env, value
1293      break;      break;
1294    }    }
1295    
1296    unprotect(env); unprotect(env);    unprotect(old_value); unprotect(new_value);
1297    
1298    return new_value;    return new_value;
1299  }  }
1300    
1301  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1302  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1303    {
1304    if((env->head)==NULL) {    if((env->head)==NULL) {
1305      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1306      env->err= 1;      env->err= 1;
# Line 1265  extern void sx_647570(environment *env) Line 1310  extern void sx_647570(environment *env)
1310  }  }
1311    
1312  /* "if", If-Then */  /* "if", If-Then */
1313  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1314    {
1315    int truth;    int truth;
1316    
1317    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
# Line 1296  extern void sx_6966(environment *env) { Line 1341  extern void sx_6966(environment *env) {
1341  }  }
1342    
1343  /* If-Then-Else */  /* If-Then-Else */
1344  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1345    {
1346    int truth;    int truth;
1347    
1348    if((env->head)==NULL || env->head->next==NULL    if((env->head)==NULL || env->head->next==NULL
# Line 1332  extern void ifelse(environment *env) { Line 1377  extern void ifelse(environment *env) {
1377  }  }
1378    
1379  /* "while" */  /* "while" */
1380  extern void sx_7768696c65(environment *env) {  extern void sx_7768696c65(environment *env)
1381    {
1382    int truth;    int truth;
1383    value *loop, *test;    value *loop, *test;
1384    
# Line 1344  extern void sx_7768696c65(environment *e Line 1389  extern void sx_7768696c65(environment *e
1389    }    }
1390    
1391    loop= env->head->item;    loop= env->head->item;
1392    protect(env, loop);    protect(loop);
1393    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1394    
1395    test= env->head->item;    test= env->head->item;
1396    protect(env, test);    protect(test);
1397    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1398    
1399    do {    do {
# Line 1373  extern void sx_7768696c65(environment *e Line 1418  extern void sx_7768696c65(environment *e
1418        
1419    } while(truth);    } while(truth);
1420    
1421    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1422  }  }
1423    
1424    
1425  /* "for"; for-loop */  /* "for"; for-loop */
1426  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1427    {
1428    value *loop;    value *loop;
1429    int foo1, foo2;    int foo1, foo2;
1430    
# Line 1397  extern void sx_666f72(environment *env) Line 1443  extern void sx_666f72(environment *env)
1443    }    }
1444    
1445    loop= env->head->item;    loop= env->head->item;
1446    protect(env, loop);    protect(loop);
1447    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1448    
1449    foo2= env->head->item->content.i;    foo2= env->head->item->content.i;
# Line 1421  extern void sx_666f72(environment *env) Line 1467  extern void sx_666f72(environment *env)
1467        foo1--;        foo1--;
1468      }      }
1469    }    }
1470    unprotect(env);    unprotect(loop);
1471  }  }
1472    
1473  /* Variant of for-loop */  /* Variant of for-loop */
1474  extern void foreach(environment *env) {  extern void foreach(environment *env)
1475      {  
1476    value *loop, *foo;    value *loop, *foo;
1477    stackitem *iterator;    stackitem *iterator;
1478        
# Line 1443  extern void foreach(environment *env) { Line 1489  extern void foreach(environment *env) {
1489    }    }
1490    
1491    loop= env->head->item;    loop= env->head->item;
1492    protect(env, loop);    protect(loop);
1493    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1494    
1495    foo= env->head->item;    foo= env->head->item;
1496    protect(env, foo);    protect(foo);
1497    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1498    
1499    iterator= foo->content.ptr;    iterator= foo->content.ptr;
# Line 1458  extern void foreach(environment *env) { Line 1504  extern void foreach(environment *env) {
1504      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1505      iterator= iterator->next;      iterator= iterator->next;
1506    }    }
1507    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1508  }  }
1509    
1510  /* "to" */  /* "to" */
1511  extern void to(environment *env) {  extern void to(environment *env)
1512    int i, start, ending;  {
1513    stackitem *temp_head;    int ending, start, i;
1514    value *temp_val;    stackitem *iterator, *temp;
1515        value *pack;
1516    
1517    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1518      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1519      env->err=1;      env->err=1;
# Line 1485  extern void to(environment *env) { Line 1532  extern void to(environment *env) {
1532    start= env->head->item->content.i;    start= env->head->item->content.i;
1533    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1534    
1535    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1536    
1537    if(ending>=start) {    if(ending>=start) {
1538      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1496  extern void to(environment *env) { Line 1542  extern void to(environment *env) {
1542        push_int(env, i);        push_int(env, i);
1543    }    }
1544    
1545    temp_val= new_val(env);    iterator= env->head;
1546    protect(env, temp_val);    pack= new_val(env);
1547      protect(pack);
1548    
1549      if(iterator==NULL
1550         || (iterator->item->type==symb
1551         && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {
1552        temp= NULL;
1553        toss(env);
1554      } else {
1555        /* Search for first delimiter */
1556        while(iterator->next!=NULL
1557              && (iterator->next->item->type!=symb
1558              || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))
1559          iterator= iterator->next;
1560        
1561        /* Extract list */
1562        temp= env->head;
1563        env->head= iterator->next;
1564        iterator->next= NULL;
1565    
1566        pack->type= list;
1567        pack->content.ptr= temp;
1568        
1569        if(env->head!=NULL)
1570          toss(env);
1571      }
1572    
1573      /* Push list */
1574    
1575    temp_val->content.ptr= env->head;    push_val(env, pack);
   temp_val->type= list;  
   env->head= temp_head;  
   push_val(env, temp_val);  
1576    
1577    unprotect(env);    unprotect(pack);
1578  }  }
1579    
1580  /* Read a string */  /* Read a string */
1581  extern void readline(environment *env) {  extern void readline(environment *env)
1582    {
1583    char in_string[101];    char in_string[101];
1584    
1585    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1518  extern void readline(environment *env) { Line 1589  extern void readline(environment *env) {
1589  }  }
1590    
1591  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1592  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1593    {
1594    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1595    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1596    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1597  extern void sx_72656164(environment *env Line 1669  extern void sx_72656164(environment *env
1669      return sx_72656164(env);      return sx_72656164(env);
1670  }  }
1671    
1672  extern void beep(environment *env) {  extern void beep(environment *env)
1673    {
1674    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1675    
1676    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
# Line 1638  extern void beep(environment *env) { Line 1710  extern void beep(environment *env) {
1710    default:    default:
1711      abort();      abort();
1712    }    }
1713  };  }
1714    
1715  /* "wait" */  /* "wait" */
1716  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1717    {
1718    int dur;    int dur;
1719    
1720    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 1661  extern void sx_77616974(environment *env Line 1733  extern void sx_77616974(environment *env
1733    toss(env);    toss(env);
1734    
1735    usleep(dur);    usleep(dur);
1736  };  }
1737    
1738  extern void copying(environment *env){  extern void copying(environment *env)
1739    {
1740    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1741                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1742  \n\  \n\
# Line 1922  of preserving the free status of all der Line 1995  of preserving the free status of all der
1995  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
1996  }  }
1997    
1998  extern void warranty(environment *env){  extern void warranty(environment *env)
1999    {
2000    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
2001  \n\  \n\
2002    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\
Legend:
Removed from v.1.94  
changed lines
  Added in v.1.99
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26