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

Diff of /stack/stack.c

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

revision 1.93 by masse, Fri Mar 8 16:09:30 2002 UTC revision 1.101 by teddy, Sun Mar 10 13:00:01 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.");
   
   /* 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);
223        new_head= env->gc_ref;        if(env->gc_ref->item->type == string)
224        env->gc_ref= titem;          env->gc_count += strlen(env->gc_ref->item->content.ptr);
       env->gc_count++;  
225      }      }
226        
227        /* Keep values */
228        titem= env->gc_ref->next;
229        env->gc_ref->next= new_head;
230        new_head= env->gc_ref;
231        new_head->item->gc.flag.mark= 0;
232        env->gc_ref= titem;
233    }    }
234    
235    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
236        env->gc_limit= env->gc_count*2;
237    
238    env->gc_ref= new_head;    env->gc_ref= new_head;
239    
240      if(env->interactive){
241        printf("done\n");
242      }
243    
244  }  }
245    
246  void protect(environment *env, value *val)  /* Protect values from GC */
247    void protect(value *val)
248  {  {
249    stackitem *new_item= malloc(sizeof(stackitem));    stackitem *iterator;
250    new_item->item= val;  
251    new_item->next= env->gc_protect;    if(val->gc.flag.protect)
252    env->gc_protect= new_item;      return;
253    
254      val->gc.flag.protect= 1;
255    
256      if(val->type==list) {
257        iterator= val->content.ptr;
258    
259        while(iterator!=NULL) {
260          protect(iterator->item);
261          iterator= iterator->next;
262        }
263      }
264  }  }
265    
266  void unprotect(environment *env)  /* Unprotect values from GC */
267    void unprotect(value *val)
268  {  {
269    stackitem *temp= env->gc_protect;    stackitem *iterator;
270    env->gc_protect= env->gc_protect->next;  
271    free(temp);    if(!(val->gc.flag.protect))
272        return;
273    
274      val->gc.flag.protect= 0;
275    
276      if(val->type==list) {
277        iterator= val->content.ptr;
278    
279        while(iterator!=NULL) {
280          unprotect(iterator->item);
281          iterator= iterator->next;
282        }
283      }
284  }  }
285    
286  /* Push a value onto the stack */  /* Push a value onto the stack */
# Line 251  void push_val(environment *env, value *v Line 292  void push_val(environment *env, value *v
292    env->head= new_item;    env->head= new_item;
293  }  }
294    
295  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
296  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
297  {  {
298    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 262  void push_int(environment *env, int in_v Line 303  void push_int(environment *env, int in_v
303    push_val(env, new_value);    push_val(env, new_value);
304  }  }
305    
306    /* Push a floating point number onto the stack */
307  void push_float(environment *env, float in_val)  void push_float(environment *env, float in_val)
308  {  {
309    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 276  void push_float(environment *env, float Line 318  void push_float(environment *env, float
318  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
319  {  {
320    value *new_value= new_val(env);    value *new_value= new_val(env);
321      int length= strlen(in_string)+1;
322    
323    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
324      env->gc_count += length;
325    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
326    new_value->type= string;    new_value->type= string;
327    
# Line 285  void push_cstring(environment *env, cons Line 329  void push_cstring(environment *env, cons
329  }  }
330    
331  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
332  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
333    {
334    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
335    char *new_string, *current;    char *new_string, *current;
336    
# Line 303  char *mangle_str(const char *old_string) Line 348  char *mangle_str(const char *old_string)
348    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
349  }  }
350    
351  extern void mangle(environment *env){  extern void mangle(environment *env)
352    {
353    char *new_string;    char *new_string;
354    
355    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 342  void push_sym(environment *env, const ch Line 388  void push_sym(environment *env, const ch
388    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
389    
390    new_value= new_val(env);    new_value= new_val(env);
391    protect(env, new_value);    protect(new_value);
392    new_fvalue= new_val(env);    new_fvalue= new_val(env);
393    protect(env, new_fvalue);    protect(new_fvalue);
394    
395    /* The new value is a symbol */    /* The new value is a symbol */
396    new_value->type= symb;    new_value->type= symb;
# Line 372  void push_sym(environment *env, const ch Line 418  void push_sym(environment *env, const ch
418    
419      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
420      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
421      free(mangled);  
422      dlerr= dlerror();      dlerr= dlerror();
423      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
424        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
425        dlerr= dlerror();        dlerr= dlerror();
426      }      }
427    
428      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
429        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
430        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
431        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
432                                           function value */                                           function value */
433      }      }
434    
435        free(mangled);
436    }    }
437    
438    push_val(env, new_value);    push_val(env, new_value);
439    unprotect(env); unprotect(env);    unprotect(new_value); unprotect(new_fvalue);
440  }  }
441    
442  /* Print newline. */  /* Print newline. */
# Line 396  extern void nl() Line 446  extern void nl()
446  }  }
447    
448  /* Gets the type of a value */  /* Gets the type of a value */
449  extern void type(environment *env){  extern void type(environment *env)
450    {
451    int typenum;    int typenum;
452    
453    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 464  void print_h(stackitem *stack_head, int Line 515  void print_h(stackitem *stack_head, int
515    }    }
516  }  }
517    
518  extern void print_(environment *env) {  extern void print_(environment *env)
519    {
520    if(env->head==NULL) {    if(env->head==NULL) {
521      printerr("Too Few Arguments");      printerr("Too Few Arguments");
522      env->err=1;      env->err=1;
# Line 482  extern void print(environment *env) Line 534  extern void print(environment *env)
534    toss(env);    toss(env);
535  }  }
536    
537  extern void princ_(environment *env) {  extern void princ_(environment *env)
538    {
539    if(env->head==NULL) {    if(env->head==NULL) {
540      printerr("Too Few Arguments");      printerr("Too Few Arguments");
541      env->err=1;      env->err=1;
# Line 516  extern void printstack(environment *env) Line 569  extern void printstack(environment *env)
569      printf("Stack Empty\n");      printf("Stack Empty\n");
570      return;      return;
571    }    }
572    
573    print_st(env->head, 1);    print_st(env->head, 1);
574  }  }
575    
# Line 575  extern void rcl(environment *env) Line 629  extern void rcl(environment *env)
629      env->err=3;      env->err=3;
630      return;      return;
631    }    }
632    protect(env, val);    protect(val);
633    toss(env);            /* toss the symbol */    toss(env);            /* toss the symbol */
634    if(env->err) return;    if(env->err) return;
635    push_val(env, val); /* Return its bound value */    push_val(env, val); /* Return its bound value */
636    unprotect(env);    unprotect(val);
637  }  }
638    
639  /* 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 647  extern void eval(environment *env)
647    
648   eval_start:   eval_start:
649    
650      gc_maybe(env);
651    
652    if(env->head==NULL) {    if(env->head==NULL) {
653      printerr("Too Few Arguments");      printerr("Too Few Arguments");
654      env->err=1;      env->err=1;
# Line 619  extern void eval(environment *env) Line 675  extern void eval(environment *env)
675      /* If it's a list */      /* If it's a list */
676    case list:    case list:
677      temp_val= env->head->item;      temp_val= env->head->item;
678      protect(env, temp_val);      protect(temp_val);
679    
680      toss(env); if(env->err) return;      toss(env); if(env->err) return;
681      iterator= (stackitem*)temp_val->content.ptr;      iterator= (stackitem*)temp_val->content.ptr;
# Line 628  extern void eval(environment *env) Line 684  extern void eval(environment *env)
684        push_val(env, iterator->item);        push_val(env, iterator->item);
685                
686        if(env->head->item->type==symb        if(env->head->item->type==symb
687          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && (((symbol*)(env->head->item->content.ptr))->id[0] == ';')) {
688          toss(env);          toss(env);
689          if(env->err) return;          if(env->err) return;
690                    
# Line 640  extern void eval(environment *env) Line 696  extern void eval(environment *env)
696        }        }
697        iterator= iterator->next;        iterator= iterator->next;
698      }      }
699      unprotect(env);      unprotect(temp_val);
700      return;      return;
701    
702    default:    default:
# Line 649  extern void eval(environment *env) Line 705  extern void eval(environment *env)
705  }  }
706    
707  /* Reverse (flip) a list */  /* Reverse (flip) a list */
708  extern void rev(environment *env){  extern void rev(environment *env)
709    {
710    stackitem *old_head, *new_head, *item;    stackitem *old_head, *new_head, *item;
711    
712    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 683  extern void pack(environment *env) Line 740  extern void pack(environment *env)
740    
741    iterator= env->head;    iterator= env->head;
742    pack= new_val(env);    pack= new_val(env);
743    protect(env, pack);    protect(pack);
744    
745    if(iterator==NULL    if(iterator==NULL
746       || (iterator->item->type==symb       || (iterator->item->type==symb
# Line 714  extern void pack(environment *env) Line 771  extern void pack(environment *env)
771    push_val(env, pack);    push_val(env, pack);
772    rev(env);    rev(env);
773    
774    unprotect(env);    unprotect(pack);
775  }  }
776    
777  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
# Line 835  extern void def(environment *env) Line 892  extern void def(environment *env)
892  /* Quit stack. */  /* Quit stack. */
893  extern void quit(environment *env)  extern void quit(environment *env)
894  {  {
895    long i;    int i;
896    
897    clear(env);    clear(env);
898    
# Line 848  extern void quit(environment *env) Line 905  extern void quit(environment *env)
905    }    }
906    
907    env->gc_limit= 0;    env->gc_limit= 0;
908    gc_init(env);    gc_maybe(env);
909    
910    if(env->free_string!=NULL)    if(env->free_string!=NULL)
911      free(env->free_string);      free(env->free_string);
# Line 881  extern void words(environment *env) Line 938  extern void words(environment *env)
938  }  }
939    
940  /* Internal forget function */  /* Internal forget function */
941  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
942    {
943    symbol *temp;    symbol *temp;
944    
945    temp= *hash_entry;    temp= *hash_entry;
# Line 916  extern void forget(environment *env) Line 974  extern void forget(environment *env)
974  }  }
975    
976  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
977  extern void errn(environment *env){  extern void errn(environment *env)
978    {
979    push_int(env, env->err);    push_int(env, env->err);
980  }  }
981    
# Line 985  under certain conditions; type `copying; Line 1044  under certain conditions; type `copying;
1044        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1045        eval(&myenv);        eval(&myenv);
1046      }      }
1047      gc_init(&myenv);      gc_maybe(&myenv);
1048    }    }
1049    quit(&myenv);    quit(&myenv);
1050    return EXIT_FAILURE;    return EXIT_FAILURE;
1051  }  }
1052    
1053  /* "+" */  /* "+" */
1054  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1055    {
1056    int a, b;    int a, b;
1057    float fa, fb;    float fa, fb;
1058    size_t len;    size_t len;
# Line 1009  extern void sx_2b(environment *env) { Line 1069  extern void sx_2b(environment *env) {
1069       && env->head->next->item->type==string) {       && env->head->next->item->type==string) {
1070      a_val= env->head->item;      a_val= env->head->item;
1071      b_val= env->head->next->item;      b_val= env->head->next->item;
1072      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1073      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1074      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1075      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 1077  extern void sx_2b(environment *env) {
1077      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1078      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1079      push_cstring(env, new_string);      push_cstring(env, new_string);
1080      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1081      free(new_string);      free(new_string);
1082            
1083      return;      return;
# Line 1072  extern void sx_2b(environment *env) { Line 1132  extern void sx_2b(environment *env) {
1132  }  }
1133    
1134  /* "-" */  /* "-" */
1135  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1136    {
1137    int a, b;    int a, b;
1138    float fa, fb;    float fa, fb;
1139    
# Line 1131  extern void sx_2d(environment *env) { Line 1192  extern void sx_2d(environment *env) {
1192  }  }
1193    
1194  /* ">" */  /* ">" */
1195  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1196    {
1197    int a, b;    int a, b;
1198    float fa, fb;    float fa, fb;
1199    
# Line 1190  extern void sx_3e(environment *env) { Line 1252  extern void sx_3e(environment *env) {
1252  }  }
1253    
1254  /* "<" */  /* "<" */
1255  extern void sx_3c(environment *env) {  extern void sx_3c(environment *env)
1256    {
1257    swap(env); if(env->err) return;    swap(env); if(env->err) return;
1258    sx_3e(env);    sx_3e(env);
1259  }  }
1260    
1261  /* "<=" */  /* "<=" */
1262  extern void sx_3c3d(environment *env) {  extern void sx_3c3d(environment *env)
1263    {
1264    sx_3e(env); if(env->err) return;    sx_3e(env); if(env->err) return;
1265    not(env);    not(env);
1266  }  }
1267    
1268  /* ">=" */  /* ">=" */
1269  extern void sx_3e3d(environment *env) {  extern void sx_3e3d(environment *env)
1270    {
1271    sx_3c(env); if(env->err) return;    sx_3c(env); if(env->err) return;
1272    not(env);    not(env);
1273  }  }
1274    
1275  /* Return copy of a value */  /* Return copy of a value */
1276  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1277    {
1278    stackitem *old_item, *new_item, *prev_item;    stackitem *old_item, *new_item, *prev_item;
1279    value *new_value;    value *new_value;
1280    
1281    protect(env, old_value);    protect(old_value);
1282    new_value= new_val(env);    new_value= new_val(env);
1283    protect(env, new_value);    protect(new_value);
1284    new_value->type= old_value->type;    new_value->type= old_value->type;
1285    
1286    switch(old_value->type){    switch(old_value->type){
# Line 1249  value *copy_val(environment *env, value Line 1315  value *copy_val(environment *env, value
1315      break;      break;
1316    }    }
1317    
1318    unprotect(env); unprotect(env);    unprotect(old_value); unprotect(new_value);
1319    
1320    return new_value;    return new_value;
1321  }  }
1322    
1323  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1324  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1325    {
1326    if((env->head)==NULL) {    if((env->head)==NULL) {
1327      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1328      env->err= 1;      env->err= 1;
# Line 1265  extern void sx_647570(environment *env) Line 1332  extern void sx_647570(environment *env)
1332  }  }
1333    
1334  /* "if", If-Then */  /* "if", If-Then */
1335  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1336    {
1337    int truth;    int truth;
1338    
1339    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 1363  extern void sx_6966(environment *env) {
1363  }  }
1364    
1365  /* If-Then-Else */  /* If-Then-Else */
1366  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1367    {
1368    int truth;    int truth;
1369    
1370    if((env->head)==NULL || env->head->next==NULL    if((env->head)==NULL || env->head->next==NULL
# Line 1332  extern void ifelse(environment *env) { Line 1399  extern void ifelse(environment *env) {
1399  }  }
1400    
1401  /* "while" */  /* "while" */
1402  extern void sx_7768696c65(environment *env) {  extern void sx_7768696c65(environment *env)
1403    {
1404    int truth;    int truth;
1405    value *loop, *test;    value *loop, *test;
1406    
# Line 1344  extern void sx_7768696c65(environment *e Line 1411  extern void sx_7768696c65(environment *e
1411    }    }
1412    
1413    loop= env->head->item;    loop= env->head->item;
1414    protect(env, loop);    protect(loop);
1415    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1416    
1417    test= env->head->item;    test= env->head->item;
1418    protect(env, test);    protect(test);
1419    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1420    
1421    do {    do {
# Line 1373  extern void sx_7768696c65(environment *e Line 1440  extern void sx_7768696c65(environment *e
1440        
1441    } while(truth);    } while(truth);
1442    
1443    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1444  }  }
1445    
1446    
1447  /* "for"; for-loop */  /* "for"; for-loop */
1448  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1449    {
1450    value *loop;    value *loop;
1451    int foo1, foo2;    int foo1, foo2;
1452    
# Line 1397  extern void sx_666f72(environment *env) Line 1465  extern void sx_666f72(environment *env)
1465    }    }
1466    
1467    loop= env->head->item;    loop= env->head->item;
1468    protect(env, loop);    protect(loop);
1469    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1470    
1471    foo2= env->head->item->content.i;    foo2= env->head->item->content.i;
# Line 1421  extern void sx_666f72(environment *env) Line 1489  extern void sx_666f72(environment *env)
1489        foo1--;        foo1--;
1490      }      }
1491    }    }
1492    unprotect(env);    unprotect(loop);
1493  }  }
1494    
1495  /* Variant of for-loop */  /* Variant of for-loop */
1496  extern void foreach(environment *env) {  extern void foreach(environment *env)
1497      {  
1498    value *loop, *foo;    value *loop, *foo;
1499    stackitem *iterator;    stackitem *iterator;
1500        
# Line 1443  extern void foreach(environment *env) { Line 1511  extern void foreach(environment *env) {
1511    }    }
1512    
1513    loop= env->head->item;    loop= env->head->item;
1514    protect(env, loop);    protect(loop);
1515    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1516    
1517    foo= env->head->item;    foo= env->head->item;
1518    protect(env, foo);    protect(foo);
1519    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1520    
1521    iterator= foo->content.ptr;    iterator= foo->content.ptr;
# Line 1458  extern void foreach(environment *env) { Line 1526  extern void foreach(environment *env) {
1526      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1527      iterator= iterator->next;      iterator= iterator->next;
1528    }    }
1529    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1530  }  }
1531    
1532  /* "to" */  /* "to" */
1533  extern void to(environment *env) {  extern void to(environment *env)
1534    int i, start, ending;  {
1535    stackitem *temp_head;    int ending, start, i;
1536    value *temp_val;    stackitem *iterator, *temp;
1537        value *pack;
1538    
1539    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1540      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1541      env->err=1;      env->err=1;
# Line 1485  extern void to(environment *env) { Line 1554  extern void to(environment *env) {
1554    start= env->head->item->content.i;    start= env->head->item->content.i;
1555    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1556    
1557    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1558    
1559    if(ending>=start) {    if(ending>=start) {
1560      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1496  extern void to(environment *env) { Line 1564  extern void to(environment *env) {
1564        push_int(env, i);        push_int(env, i);
1565    }    }
1566    
1567    temp_val= new_val(env);    iterator= env->head;
1568    protect(env, temp_val);    pack= new_val(env);
1569      protect(pack);
1570    
1571    temp_val->content.ptr= env->head;    if(iterator==NULL
1572    temp_val->type= list;       || (iterator->item->type==symb
1573    env->head= temp_head;       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {
1574    push_val(env, temp_val);      temp= NULL;
1575        toss(env);
1576      } else {
1577        /* Search for first delimiter */
1578        while(iterator->next!=NULL
1579              && (iterator->next->item->type!=symb
1580              || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))
1581          iterator= iterator->next;
1582        
1583        /* Extract list */
1584        temp= env->head;
1585        env->head= iterator->next;
1586        iterator->next= NULL;
1587    
1588    unprotect(env);      pack->type= list;
1589        pack->content.ptr= temp;
1590        
1591        if(env->head!=NULL)
1592          toss(env);
1593      }
1594    
1595      /* Push list */
1596    
1597      push_val(env, pack);
1598    
1599      unprotect(pack);
1600  }  }
1601    
1602  /* Read a string */  /* Read a string */
1603  extern void readline(environment *env) {  extern void readline(environment *env)
1604    {
1605    char in_string[101];    char in_string[101];
1606    
1607    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1518  extern void readline(environment *env) { Line 1611  extern void readline(environment *env) {
1611  }  }
1612    
1613  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1614  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1615    {
1616    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1617    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1618    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1597  extern void sx_72656164(environment *env Line 1691  extern void sx_72656164(environment *env
1691      return sx_72656164(env);      return sx_72656164(env);
1692  }  }
1693    
1694  extern void beep(environment *env) {  extern void beep(environment *env)
1695    {
1696    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1697    
1698    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
# Line 1638  extern void beep(environment *env) { Line 1732  extern void beep(environment *env) {
1732    default:    default:
1733      abort();      abort();
1734    }    }
1735  };  }
1736    
1737  /* "wait" */  /* "wait" */
1738  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1739    {
1740    int dur;    int dur;
1741    
1742    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 1661  extern void sx_77616974(environment *env Line 1755  extern void sx_77616974(environment *env
1755    toss(env);    toss(env);
1756    
1757    usleep(dur);    usleep(dur);
1758  };  }
1759    
1760  extern void copying(environment *env){  extern void copying(environment *env)
1761    {
1762    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1763                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1764  \n\  \n\
# Line 1922  of preserving the free status of all der Line 2017  of preserving the free status of all der
2017  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
2018  }  }
2019    
2020  extern void warranty(environment *env){  extern void warranty(environment *env)
2021    {
2022    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
2023  \n\  \n\
2024    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 2073  extern void mod(environment *env) Line 2169  extern void mod(environment *env)
2169    
2170    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
2171      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2172      env->err=1;      env->err= 1;
2173      return;      return;
2174    }    }
2175        
# Line 2091  extern void mod(environment *env) Line 2187  extern void mod(environment *env)
2187    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2188    env->err=2;    env->err=2;
2189  }  }
2190    
2191    /* "div" */
2192    extern void sx_646976(environment *env)
2193    {
2194      int a, b;
2195      
2196      if((env->head)==NULL || env->head->next==NULL) {
2197        printerr("Too Few Arguments");
2198        env->err= 1;
2199        return;
2200      }
2201    
2202      if(env->head->item->type==integer
2203         && env->head->next->item->type==integer) {
2204        a= env->head->item->content.i;
2205        toss(env); if(env->err) return;
2206        b= env->head->item->content.i;
2207        toss(env); if(env->err) return;
2208        push_int(env, (int)b/a);
2209    
2210        return;
2211      }
2212    
2213      printerr("Bad Argument Type");
2214      env->err= 2;
2215    }
Legend:
Removed from v.1.93  
changed lines
  Added in v.1.101
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26