/[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.100 by teddy, Sun Mar 10 12:05:20 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= 400000;
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 80  extern void toss(environment *env) Line 80  extern void toss(environment *env)
80        
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 */
   
   gc_init(env);  
83  }  }
84    
85  /* 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 111  symbol **hash(hashtbl in_hashtbl, const
111    }    }
112  }  }
113    
114  value* new_val(environment *env) {  /* Create new value */
115    value* new_val(environment *env)
116    {
117    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
118    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
119    
# Line 123  value* new_val(environment *env) { Line 123  value* new_val(environment *env) {
123    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
124    env->gc_ref= nitem;    env->gc_ref= nitem;
125    
126    env->gc_count++;    env->gc_count+=sizeof(value);
127      nval->gc.flag.mark= 0;
128    protect(env, nval);    nval->gc.flag.protect= 0;
   gc_init(env);  
   unprotect(env);  
129    
130    return nval;    return nval;
131  }  }
132    
133  void gc_mark(value *val) {  /* Mark values recursively.
134       Marked values are not collected by the GC. */
135    inline void gc_mark(value *val)
136    {
137    stackitem *iterator;    stackitem *iterator;
138    
139    if(val==NULL || val->gc_garb==0)    if(val->gc.flag.mark)
140      return;      return;
141    
142    val->gc_garb= 0;    val->gc.flag.mark= 1;
143    
144    if(val->type==list) {    if(val->type==list) {
145      iterator= val->content.ptr;      iterator= val->content.ptr;
# Line 150  void gc_mark(value *val) { Line 151  void gc_mark(value *val) {
151    }    }
152  }  }
153    
154  extern void gc_init(environment *env) {  inline void gc_maybe(environment *env)
155    {
156      if(env->gc_count < env->gc_limit)
157        return;
158      else
159        return gc_init(env);
160    }
161    
162    /* Start GC */
163    extern void gc_init(environment *env)
164    {
165    stackitem *new_head= NULL, *titem, *iterator;    stackitem *new_head= NULL, *titem, *iterator;
166    symbol *tsymb;    symbol *tsymb;
167    int i;    int i;
168    
169    if(env->gc_count < env->gc_limit)    if(env->interactive){
170      return;      printf("Garbage collecting.", env->gc_count, env->gc_limit);
   
   /* Garb by default */  
   iterator= env->gc_ref;  
   while(iterator!=NULL) {  
     iterator->item->gc_garb= 1;  
     iterator= iterator->next;  
171    }    }
172    
173    /* Mark protected values */    /* Mark values on stack */
174    iterator= env->gc_protect;    iterator= env->head;
175    while(iterator!=NULL) {    while(iterator!=NULL) {
176      gc_mark(iterator->item);      gc_mark(iterator->item);
177      iterator= iterator->next;      iterator= iterator->next;
178    }    }
179    
180    /* Mark values in stack */    if(env->interactive){
181    iterator= env->head;      printf(".");
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
182    }    }
183    
184    /* Mark values in hashtable */    /* Mark values in hashtable */
185    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
186      tsymb= env->symbols[i];      tsymb= env->symbols[i];
187      while(tsymb!=NULL) {      while(tsymb!=NULL) {
188        gc_mark(tsymb->val);        if (tsymb->val != NULL)
189            gc_mark(tsymb->val);
190        tsymb= tsymb->next;        tsymb= tsymb->next;
191      }      }
192    }    }
193    
194      if(env->interactive){
195        printf(".");
196      }
197    
198    env->gc_count= 0;    env->gc_count= 0;
199    
200    /* Sweep */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
   while(env->gc_ref!=NULL) {  
201    
202      if(env->gc_ref->item->gc_garb) {      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
203    
204        /* Remove content */        switch(env->gc_ref->item->type) { /* Remove content */
       switch(env->gc_ref->item->type) {  
205        case string:        case string:
206          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
207          break;          break;
# Line 206  extern void gc_init(environment *env) { Line 211  extern void gc_init(environment *env) {
211            env->gc_ref->item->content.ptr= titem->next;            env->gc_ref->item->content.ptr= titem->next;
212            free(titem);            free(titem);
213          }          }
         break;  
214        default:        default:
         break;  
215        }        }
216        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
217        titem= env->gc_ref->next;        titem= env->gc_ref->next;
218        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
219        env->gc_ref= titem;        env->gc_ref= titem;
220      } else {                    /* Save */        continue;
221        titem= env->gc_ref->next;      } else {
222        env->gc_ref->next= new_head;        env->gc_count += sizeof(value);
       new_head= env->gc_ref;  
       env->gc_ref= titem;  
       env->gc_count++;  
223      }      }
224        
225        /* Keep values */
226        titem= env->gc_ref->next;
227        env->gc_ref->next= new_head;
228        new_head= env->gc_ref;
229        new_head->item->gc.flag.mark= 0;
230        env->gc_ref= titem;
231    }    }
232    
233    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
234        env->gc_limit= env->gc_count*2;
235    env->gc_ref= new_head;    env->gc_ref= new_head;
236    
237      if(env->interactive){
238        printf("done\n");
239      }
240    
241  }  }
242    
243  void protect(environment *env, value *val)  /* Protect values from GC */
244    void protect(value *val)
245  {  {
246    stackitem *new_item= malloc(sizeof(stackitem));    stackitem *iterator;
247    new_item->item= val;  
248    new_item->next= env->gc_protect;    if(val->gc.flag.protect)
249    env->gc_protect= new_item;      return;
250    
251      val->gc.flag.protect= 1;
252    
253      if(val->type==list) {
254        iterator= val->content.ptr;
255    
256        while(iterator!=NULL) {
257          protect(iterator->item);
258          iterator= iterator->next;
259        }
260      }
261  }  }
262    
263  void unprotect(environment *env)  /* Unprotect values from GC */
264    void unprotect(value *val)
265  {  {
266    stackitem *temp= env->gc_protect;    stackitem *iterator;
267    env->gc_protect= env->gc_protect->next;  
268    free(temp);    if(!(val->gc.flag.protect))
269        return;
270    
271      val->gc.flag.protect= 0;
272    
273      if(val->type==list) {
274        iterator= val->content.ptr;
275    
276        while(iterator!=NULL) {
277          unprotect(iterator->item);
278          iterator= iterator->next;
279        }
280      }
281  }  }
282    
283  /* Push a value onto the stack */  /* Push a value onto the stack */
# Line 251  void push_val(environment *env, value *v Line 289  void push_val(environment *env, value *v
289    env->head= new_item;    env->head= new_item;
290  }  }
291    
292  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
293  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
294  {  {
295    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 262  void push_int(environment *env, int in_v Line 300  void push_int(environment *env, int in_v
300    push_val(env, new_value);    push_val(env, new_value);
301  }  }
302    
303    /* Push a floating point number onto the stack */
304  void push_float(environment *env, float in_val)  void push_float(environment *env, float in_val)
305  {  {
306    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 285  void push_cstring(environment *env, cons Line 324  void push_cstring(environment *env, cons
324  }  }
325    
326  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
327  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
328    {
329    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
330    char *new_string, *current;    char *new_string, *current;
331    
# Line 303  char *mangle_str(const char *old_string) Line 343  char *mangle_str(const char *old_string)
343    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
344  }  }
345    
346  extern void mangle(environment *env){  extern void mangle(environment *env)
347    {
348    char *new_string;    char *new_string;
349    
350    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 342  void push_sym(environment *env, const ch Line 383  void push_sym(environment *env, const ch
383    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
384    
385    new_value= new_val(env);    new_value= new_val(env);
386    protect(env, new_value);    protect(new_value);
387    new_fvalue= new_val(env);    new_fvalue= new_val(env);
388    protect(env, new_fvalue);    protect(new_fvalue);
389    
390    /* The new value is a symbol */    /* The new value is a symbol */
391    new_value->type= symb;    new_value->type= symb;
# Line 372  void push_sym(environment *env, const ch Line 413  void push_sym(environment *env, const ch
413    
414      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
415      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
416      free(mangled);  
417      dlerr= dlerror();      dlerr= dlerror();
418      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
419        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
420        dlerr= dlerror();        dlerr= dlerror();
421      }      }
422    
423      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
424        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
425        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
426        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
427                                           function value */                                           function value */
428      }      }
429    
430        free(mangled);
431    }    }
432    
433    push_val(env, new_value);    push_val(env, new_value);
434    unprotect(env); unprotect(env);    unprotect(new_value); unprotect(new_fvalue);
435  }  }
436    
437  /* Print newline. */  /* Print newline. */
# Line 396  extern void nl() Line 441  extern void nl()
441  }  }
442    
443  /* Gets the type of a value */  /* Gets the type of a value */
444  extern void type(environment *env){  extern void type(environment *env)
445    {
446    int typenum;    int typenum;
447    
448    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 464  void print_h(stackitem *stack_head, int Line 510  void print_h(stackitem *stack_head, int
510    }    }
511  }  }
512    
513  extern void print_(environment *env) {  extern void print_(environment *env)
514    {
515    if(env->head==NULL) {    if(env->head==NULL) {
516      printerr("Too Few Arguments");      printerr("Too Few Arguments");
517      env->err=1;      env->err=1;
# Line 482  extern void print(environment *env) Line 529  extern void print(environment *env)
529    toss(env);    toss(env);
530  }  }
531    
532  extern void princ_(environment *env) {  extern void princ_(environment *env)
533    {
534    if(env->head==NULL) {    if(env->head==NULL) {
535      printerr("Too Few Arguments");      printerr("Too Few Arguments");
536      env->err=1;      env->err=1;
# Line 516  extern void printstack(environment *env) Line 564  extern void printstack(environment *env)
564      printf("Stack Empty\n");      printf("Stack Empty\n");
565      return;      return;
566    }    }
567    
568    print_st(env->head, 1);    print_st(env->head, 1);
569  }  }
570    
# Line 575  extern void rcl(environment *env) Line 624  extern void rcl(environment *env)
624      env->err=3;      env->err=3;
625      return;      return;
626    }    }
627    protect(env, val);    protect(val);
628    toss(env);            /* toss the symbol */    toss(env);            /* toss the symbol */
629    if(env->err) return;    if(env->err) return;
630    push_val(env, val); /* Return its bound value */    push_val(env, val); /* Return its bound value */
631    unprotect(env);    unprotect(val);
632  }  }
633    
634  /* 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 642  extern void eval(environment *env)
642    
643   eval_start:   eval_start:
644    
645      gc_maybe(env);
646    
647    if(env->head==NULL) {    if(env->head==NULL) {
648      printerr("Too Few Arguments");      printerr("Too Few Arguments");
649      env->err=1;      env->err=1;
# Line 619  extern void eval(environment *env) Line 670  extern void eval(environment *env)
670      /* If it's a list */      /* If it's a list */
671    case list:    case list:
672      temp_val= env->head->item;      temp_val= env->head->item;
673      protect(env, temp_val);      protect(temp_val);
674    
675      toss(env); if(env->err) return;      toss(env); if(env->err) return;
676      iterator= (stackitem*)temp_val->content.ptr;      iterator= (stackitem*)temp_val->content.ptr;
# Line 628  extern void eval(environment *env) Line 679  extern void eval(environment *env)
679        push_val(env, iterator->item);        push_val(env, iterator->item);
680                
681        if(env->head->item->type==symb        if(env->head->item->type==symb
682          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && (((symbol*)(env->head->item->content.ptr))->id[0] == ';')) {
683          toss(env);          toss(env);
684          if(env->err) return;          if(env->err) return;
685                    
# Line 640  extern void eval(environment *env) Line 691  extern void eval(environment *env)
691        }        }
692        iterator= iterator->next;        iterator= iterator->next;
693      }      }
694      unprotect(env);      unprotect(temp_val);
695      return;      return;
696    
697    default:    default:
# Line 649  extern void eval(environment *env) Line 700  extern void eval(environment *env)
700  }  }
701    
702  /* Reverse (flip) a list */  /* Reverse (flip) a list */
703  extern void rev(environment *env){  extern void rev(environment *env)
704    {
705    stackitem *old_head, *new_head, *item;    stackitem *old_head, *new_head, *item;
706    
707    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 683  extern void pack(environment *env) Line 735  extern void pack(environment *env)
735    
736    iterator= env->head;    iterator= env->head;
737    pack= new_val(env);    pack= new_val(env);
738    protect(env, pack);    protect(pack);
739    
740    if(iterator==NULL    if(iterator==NULL
741       || (iterator->item->type==symb       || (iterator->item->type==symb
# Line 714  extern void pack(environment *env) Line 766  extern void pack(environment *env)
766    push_val(env, pack);    push_val(env, pack);
767    rev(env);    rev(env);
768    
769    unprotect(env);    unprotect(pack);
770  }  }
771    
772  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
# Line 835  extern void def(environment *env) Line 887  extern void def(environment *env)
887  /* Quit stack. */  /* Quit stack. */
888  extern void quit(environment *env)  extern void quit(environment *env)
889  {  {
890    long i;    int i;
891    
892    clear(env);    clear(env);
893    
# Line 848  extern void quit(environment *env) Line 900  extern void quit(environment *env)
900    }    }
901    
902    env->gc_limit= 0;    env->gc_limit= 0;
903    gc_init(env);    gc_maybe(env);
904    
905    if(env->free_string!=NULL)    if(env->free_string!=NULL)
906      free(env->free_string);      free(env->free_string);
# Line 881  extern void words(environment *env) Line 933  extern void words(environment *env)
933  }  }
934    
935  /* Internal forget function */  /* Internal forget function */
936  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
937    {
938    symbol *temp;    symbol *temp;
939    
940    temp= *hash_entry;    temp= *hash_entry;
# Line 916  extern void forget(environment *env) Line 969  extern void forget(environment *env)
969  }  }
970    
971  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
972  extern void errn(environment *env){  extern void errn(environment *env)
973    {
974    push_int(env, env->err);    push_int(env, env->err);
975  }  }
976    
# Line 985  under certain conditions; type `copying; Line 1039  under certain conditions; type `copying;
1039        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1040        eval(&myenv);        eval(&myenv);
1041      }      }
1042      gc_init(&myenv);      gc_maybe(&myenv);
1043    }    }
1044    quit(&myenv);    quit(&myenv);
1045    return EXIT_FAILURE;    return EXIT_FAILURE;
1046  }  }
1047    
1048  /* "+" */  /* "+" */
1049  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1050    {
1051    int a, b;    int a, b;
1052    float fa, fb;    float fa, fb;
1053    size_t len;    size_t len;
# Line 1009  extern void sx_2b(environment *env) { Line 1064  extern void sx_2b(environment *env) {
1064       && env->head->next->item->type==string) {       && env->head->next->item->type==string) {
1065      a_val= env->head->item;      a_val= env->head->item;
1066      b_val= env->head->next->item;      b_val= env->head->next->item;
1067      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1068      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1069      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1070      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 1072  extern void sx_2b(environment *env) {
1072      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1073      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1074      push_cstring(env, new_string);      push_cstring(env, new_string);
1075      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1076      free(new_string);      free(new_string);
1077            
1078      return;      return;
# Line 1072  extern void sx_2b(environment *env) { Line 1127  extern void sx_2b(environment *env) {
1127  }  }
1128    
1129  /* "-" */  /* "-" */
1130  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1131    {
1132    int a, b;    int a, b;
1133    float fa, fb;    float fa, fb;
1134    
# Line 1131  extern void sx_2d(environment *env) { Line 1187  extern void sx_2d(environment *env) {
1187  }  }
1188    
1189  /* ">" */  /* ">" */
1190  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1191    {
1192    int a, b;    int a, b;
1193    float fa, fb;    float fa, fb;
1194    
# Line 1190  extern void sx_3e(environment *env) { Line 1247  extern void sx_3e(environment *env) {
1247  }  }
1248    
1249  /* "<" */  /* "<" */
1250  extern void sx_3c(environment *env) {  extern void sx_3c(environment *env)
1251    {
1252    swap(env); if(env->err) return;    swap(env); if(env->err) return;
1253    sx_3e(env);    sx_3e(env);
1254  }  }
1255    
1256  /* "<=" */  /* "<=" */
1257  extern void sx_3c3d(environment *env) {  extern void sx_3c3d(environment *env)
1258    {
1259    sx_3e(env); if(env->err) return;    sx_3e(env); if(env->err) return;
1260    not(env);    not(env);
1261  }  }
1262    
1263  /* ">=" */  /* ">=" */
1264  extern void sx_3e3d(environment *env) {  extern void sx_3e3d(environment *env)
1265    {
1266    sx_3c(env); if(env->err) return;    sx_3c(env); if(env->err) return;
1267    not(env);    not(env);
1268  }  }
1269    
1270  /* Return copy of a value */  /* Return copy of a value */
1271  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1272    {
1273    stackitem *old_item, *new_item, *prev_item;    stackitem *old_item, *new_item, *prev_item;
1274    value *new_value;    value *new_value;
1275    
1276    protect(env, old_value);    protect(old_value);
1277    new_value= new_val(env);    new_value= new_val(env);
1278    protect(env, new_value);    protect(new_value);
1279    new_value->type= old_value->type;    new_value->type= old_value->type;
1280    
1281    switch(old_value->type){    switch(old_value->type){
# Line 1249  value *copy_val(environment *env, value Line 1310  value *copy_val(environment *env, value
1310      break;      break;
1311    }    }
1312    
1313    unprotect(env); unprotect(env);    unprotect(old_value); unprotect(new_value);
1314    
1315    return new_value;    return new_value;
1316  }  }
1317    
1318  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1319  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1320    {
1321    if((env->head)==NULL) {    if((env->head)==NULL) {
1322      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1323      env->err= 1;      env->err= 1;
# Line 1265  extern void sx_647570(environment *env) Line 1327  extern void sx_647570(environment *env)
1327  }  }
1328    
1329  /* "if", If-Then */  /* "if", If-Then */
1330  extern void sx_6966(environment *env) {  extern void sx_6966(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 1296  extern void sx_6966(environment *env) { Line 1358  extern void sx_6966(environment *env) {
1358  }  }
1359    
1360  /* If-Then-Else */  /* If-Then-Else */
1361  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1362    {
1363    int truth;    int truth;
1364    
1365    if((env->head)==NULL || env->head->next==NULL    if((env->head)==NULL || env->head->next==NULL
# Line 1332  extern void ifelse(environment *env) { Line 1394  extern void ifelse(environment *env) {
1394  }  }
1395    
1396  /* "while" */  /* "while" */
1397  extern void sx_7768696c65(environment *env) {  extern void sx_7768696c65(environment *env)
1398    {
1399    int truth;    int truth;
1400    value *loop, *test;    value *loop, *test;
1401    
# Line 1344  extern void sx_7768696c65(environment *e Line 1406  extern void sx_7768696c65(environment *e
1406    }    }
1407    
1408    loop= env->head->item;    loop= env->head->item;
1409    protect(env, loop);    protect(loop);
1410    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1411    
1412    test= env->head->item;    test= env->head->item;
1413    protect(env, test);    protect(test);
1414    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1415    
1416    do {    do {
# Line 1373  extern void sx_7768696c65(environment *e Line 1435  extern void sx_7768696c65(environment *e
1435        
1436    } while(truth);    } while(truth);
1437    
1438    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1439  }  }
1440    
1441    
1442  /* "for"; for-loop */  /* "for"; for-loop */
1443  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1444    {
1445    value *loop;    value *loop;
1446    int foo1, foo2;    int foo1, foo2;
1447    
# Line 1397  extern void sx_666f72(environment *env) Line 1460  extern void sx_666f72(environment *env)
1460    }    }
1461    
1462    loop= env->head->item;    loop= env->head->item;
1463    protect(env, loop);    protect(loop);
1464    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1465    
1466    foo2= env->head->item->content.i;    foo2= env->head->item->content.i;
# Line 1421  extern void sx_666f72(environment *env) Line 1484  extern void sx_666f72(environment *env)
1484        foo1--;        foo1--;
1485      }      }
1486    }    }
1487    unprotect(env);    unprotect(loop);
1488  }  }
1489    
1490  /* Variant of for-loop */  /* Variant of for-loop */
1491  extern void foreach(environment *env) {  extern void foreach(environment *env)
1492      {  
1493    value *loop, *foo;    value *loop, *foo;
1494    stackitem *iterator;    stackitem *iterator;
1495        
# Line 1443  extern void foreach(environment *env) { Line 1506  extern void foreach(environment *env) {
1506    }    }
1507    
1508    loop= env->head->item;    loop= env->head->item;
1509    protect(env, loop);    protect(loop);
1510    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1511    
1512    foo= env->head->item;    foo= env->head->item;
1513    protect(env, foo);    protect(foo);
1514    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1515    
1516    iterator= foo->content.ptr;    iterator= foo->content.ptr;
# Line 1458  extern void foreach(environment *env) { Line 1521  extern void foreach(environment *env) {
1521      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1522      iterator= iterator->next;      iterator= iterator->next;
1523    }    }
1524    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1525  }  }
1526    
1527  /* "to" */  /* "to" */
1528  extern void to(environment *env) {  extern void to(environment *env)
1529    int i, start, ending;  {
1530    stackitem *temp_head;    int ending, start, i;
1531    value *temp_val;    stackitem *iterator, *temp;
1532        value *pack;
1533    
1534    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1535      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1536      env->err=1;      env->err=1;
# Line 1485  extern void to(environment *env) { Line 1549  extern void to(environment *env) {
1549    start= env->head->item->content.i;    start= env->head->item->content.i;
1550    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1551    
1552    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1553    
1554    if(ending>=start) {    if(ending>=start) {
1555      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1496  extern void to(environment *env) { Line 1559  extern void to(environment *env) {
1559        push_int(env, i);        push_int(env, i);
1560    }    }
1561    
1562    temp_val= new_val(env);    iterator= env->head;
1563    protect(env, temp_val);    pack= new_val(env);
1564      protect(pack);
1565    
1566    temp_val->content.ptr= env->head;    if(iterator==NULL
1567    temp_val->type= list;       || (iterator->item->type==symb
1568    env->head= temp_head;       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {
1569    push_val(env, temp_val);      temp= NULL;
1570        toss(env);
1571      } else {
1572        /* Search for first delimiter */
1573        while(iterator->next!=NULL
1574              && (iterator->next->item->type!=symb
1575              || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))
1576          iterator= iterator->next;
1577        
1578        /* Extract list */
1579        temp= env->head;
1580        env->head= iterator->next;
1581        iterator->next= NULL;
1582    
1583        pack->type= list;
1584        pack->content.ptr= temp;
1585        
1586        if(env->head!=NULL)
1587          toss(env);
1588      }
1589    
1590      /* Push list */
1591    
1592    unprotect(env);    push_val(env, pack);
1593    
1594      unprotect(pack);
1595  }  }
1596    
1597  /* Read a string */  /* Read a string */
1598  extern void readline(environment *env) {  extern void readline(environment *env)
1599    {
1600    char in_string[101];    char in_string[101];
1601    
1602    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1518  extern void readline(environment *env) { Line 1606  extern void readline(environment *env) {
1606  }  }
1607    
1608  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1609  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1610    {
1611    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1612    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1613    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1597  extern void sx_72656164(environment *env Line 1686  extern void sx_72656164(environment *env
1686      return sx_72656164(env);      return sx_72656164(env);
1687  }  }
1688    
1689  extern void beep(environment *env) {  extern void beep(environment *env)
1690    {
1691    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1692    
1693    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
# Line 1638  extern void beep(environment *env) { Line 1727  extern void beep(environment *env) {
1727    default:    default:
1728      abort();      abort();
1729    }    }
1730  };  }
1731    
1732  /* "wait" */  /* "wait" */
1733  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1734    {
1735    int dur;    int dur;
1736    
1737    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 1661  extern void sx_77616974(environment *env Line 1750  extern void sx_77616974(environment *env
1750    toss(env);    toss(env);
1751    
1752    usleep(dur);    usleep(dur);
1753  };  }
1754    
1755  extern void copying(environment *env){  extern void copying(environment *env)
1756    {
1757    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1758                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1759  \n\  \n\
# Line 1922  of preserving the free status of all der Line 2012  of preserving the free status of all der
2012  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
2013  }  }
2014    
2015  extern void warranty(environment *env){  extern void warranty(environment *env)
2016    {
2017    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
2018  \n\  \n\
2019    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.100
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26