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

Diff of /stack/stack.c

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

revision 1.132 by masse, Fri Aug 8 14:20:49 2003 UTC revision 1.137 by masse, Thu Feb 19 15:35:38 2004 UTC
# Line 27  const char* start_message= "Stack versio Line 27  const char* start_message= "Stack versio
27  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
28  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
29  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
30  under certain conditions; type 'copying;' for details.\n";  under certain conditions; type 'copying;' for details.";
31    
32    
33  /* Initialize a newly created environment */  /* Initialize a newly created environment */
# Line 50  void init_env(environment *env) Line 50  void init_env(environment *env)
50  }  }
51    
52    
53  void printerr(const char* in_string)  void printerr(environment *env)
54  {  {
55    fprintf(stderr, "Err: %s\n", in_string);    char *in_string;
56    
57      switch(env->err) {
58      case 0:
59        return;
60      case 1:
61        in_string= "Too Few Arguments";
62        break;
63      case 2:
64        in_string= "Bad Argument Type";
65        break;
66      case 3:
67        in_string= "Unbound Variable";
68        break;
69      case 5:
70        return perror(env->errsymb);
71      default:
72        in_string= "Unknown error";
73        break;
74      }
75    
76      fprintf(stderr, "\"%s\":\nErr: %s\n", env->errsymb, in_string);
77  }  }
78    
79    
# Line 111  value* new_val(environment *env) Line 132  value* new_val(environment *env)
132  }  }
133    
134    
 /* Mark values recursively.  
    Marked values are not collected by the GC. */  
 inline void gc_mark(value *val)  
 {  
   if(val==NULL || val->gc.flag.mark)  
     return;  
   
   val->gc.flag.mark= 1;  
   
   if(val->type==tcons) {  
     gc_mark(CAR(val));  
     gc_mark(CDR(val));  
   }  
 }  
   
   
 /* Start GC */  
 extern void gc_init(environment *env)  
 {  
   stackitem *new_head= NULL, *titem;  
   symbol *tsymb;  
   int i;  
   
   if(env->interactive)  
     printf("Garbage collecting.");  
   
   /* Mark values on stack */  
   gc_mark(env->head);  
   
   if(env->interactive)  
     printf(".");  
   
   /* Mark values in hashtable */  
   for(i= 0; i<HASHTBLSIZE; i++)  
     for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)  
       if (tsymb->val != NULL)  
         gc_mark(tsymb->val);  
   
   if(env->interactive)  
     printf(".");  
   
   env->gc_count= 0;  
   
   while(env->gc_ref!=NULL) {    /* Sweep unused values */  
     if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */  
   
       /* Remove content */  
       switch(env->gc_ref->item->type){  
       case string:  
         free(env->gc_ref->item->content.string);  
         break;  
       case tcons:  
         free(env->gc_ref->item->content.c);  
         break;  
       case port:  
       case empty:  
       case integer:  
       case tfloat:  
       case func:  
       case symb:  
         /* Symbol strings are freed when walking the hash table */  
         break;  
       }  
   
       free(env->gc_ref->item);  /* Remove from gc_ref */  
       titem= env->gc_ref->next;  
       free(env->gc_ref);        /* Remove value */  
       env->gc_ref= titem;  
       continue;  
     }  
   
 #ifdef DEBUG  
     printf("Kept value (%p)", env->gc_ref->item);  
     if(env->gc_ref->item->gc.flag.mark)  
       printf(" (marked)");  
     if(env->gc_ref->item->gc.flag.protect)  
       printf(" (protected)");  
     switch(env->gc_ref->item->type){  
     case integer:  
       printf(" integer: %d", env->gc_ref->item->content.i);  
       break;  
     case func:  
       printf(" func: %p", env->gc_ref->item->content.func);  
       break;  
     case symb:  
       printf(" symb: %s", env->gc_ref->item->content.sym->id);  
       break;  
     case tcons:  
       printf(" tcons: %p\t%p", CAR(env->gc_ref->item),  
              CDR(env->gc_ref->item));  
       break;  
     default:  
       printf(" <unknown %d>", (env->gc_ref->item->type));  
     }  
     printf("\n");  
 #endif /* DEBUG */  
   
     /* Keep values */      
     env->gc_count += sizeof(value);  
     if(env->gc_ref->item->type==string)  
       env->gc_count += strlen(env->gc_ref->item->content.string)+1;  
       
     titem= env->gc_ref->next;  
     env->gc_ref->next= new_head;  
     new_head= env->gc_ref;  
     new_head->item->gc.flag.mark= 0;  
     env->gc_ref= titem;  
   }  
   
   if (env->gc_limit < env->gc_count*2)  
     env->gc_limit= env->gc_count*2;  
   
   env->gc_ref= new_head;  
   
   if(env->interactive)  
     printf("done (%d bytes still allocated)\n", env->gc_count);  
   
 }  
   
   
 inline void gc_maybe(environment *env)  
 {  
   if(env->gc_count < env->gc_limit)  
     return;  
   else  
     return gc_init(env);  
 }  
   
   
 /* Protect values from GC */  
 void protect(value *val)  
 {  
   if(val==NULL || val->gc.flag.protect)  
     return;  
   
   val->gc.flag.protect= 1;  
   
   if(val->type==tcons) {  
     protect(CAR(val));  
     protect(CDR(val));  
   }  
 }  
   
   
 /* Unprotect values from GC */  
 void unprotect(value *val)  
 {  
   if(val==NULL || !(val->gc.flag.protect))  
     return;  
   
   val->gc.flag.protect= 0;  
   
   if(val->type==tcons) {  
     unprotect(CAR(val));  
     unprotect(CDR(val));  
   }  
 }  
   
   
135  /* Push a value onto the stack */  /* Push a value onto the stack */
136  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
137  {  {
# Line 364  void push_sym(environment *env, const ch Line 226  void push_sym(environment *env, const ch
226    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
227    
228    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
229    new_fvalue= new_val(env);    new_fvalue= new_val(env);
   protect(new_fvalue);  
230    
231    /* The new value is a symbol */    /* The new value is a symbol */
232    new_value->type= symb;    new_value->type= symb;
# Line 414  void push_sym(environment *env, const ch Line 274  void push_sym(environment *env, const ch
274    }    }
275    
276    push_val(env, new_value);    push_val(env, new_value);
   unprotect(new_value); unprotect(new_fvalue);  
277  }  }
278    
279    
# Line 427  void print_val(environment *env, value * Line 286  void print_val(environment *env, value *
286    
287    switch(val->type) {    switch(val->type) {
288    case empty:    case empty:
289      if(fprintf(stream, "[]") < 0){      if(fprintf(stream, "[]") < 0)
290        perror("print_val");        env->err= 5;
291        break;
292      case unknown:
293        if(fprintf(stream, "UNKNOWN") < 0)
294        env->err= 5;        env->err= 5;
       return;  
     }  
295      break;      break;
296    case integer:    case integer:
297      if(fprintf(stream, "%d", val->content.i) < 0){      if(fprintf(stream, "%d", val->content.i) < 0)
       perror("print_val");  
298        env->err= 5;        env->err= 5;
       return;  
     }  
299      break;      break;
300    case tfloat:    case tfloat:
301      if(fprintf(stream, "%f", val->content.f) < 0){      if(fprintf(stream, "%f", val->content.f) < 0)
       perror("print_val");  
302        env->err= 5;        env->err= 5;
       return;  
     }  
303      break;      break;
304    case string:    case string:
305      if(noquote){      if(noquote){
306        if(fprintf(stream, "%s", val->content.string) < 0){        if(fprintf(stream, "%s", val->content.string) < 0)
         perror("print_val");  
307          env->err= 5;          env->err= 5;
         return;  
       }  
308      } else {                    /* quote */      } else {                    /* quote */
309        if(fprintf(stream, "\"%s\"", val->content.string) < 0){        if(fprintf(stream, "\"%s\"", val->content.string) < 0)
         perror("print_val");  
310          env->err= 5;          env->err= 5;
         return;  
       }  
311      }      }
312      break;      break;
313    case symb:    case symb:
314      if(fprintf(stream, "%s", val->content.sym->id) < 0){      if(fprintf(stream, "%s", val->content.sym->id) < 0)
       perror("print_val");  
315        env->err= 5;        env->err= 5;
       return;  
     }  
316      break;      break;
317    case func:    case func:
318      if(fprintf(stream, "#<function %p>", val->content.func) < 0){      if(fprintf(stream, "#<function %p>", val->content.func) < 0)
       perror("print_val");  
319        env->err= 5;        env->err= 5;
       return;  
     }  
320      break;      break;
321    case port:    case port:
322      if(fprintf(stream, "#<port %p>", val->content.p) < 0){      if(fprintf(stream, "#<port %p>", val->content.p) < 0)
       perror("print_val");  
323        env->err= 5;        env->err= 5;
       return;  
     }  
324      break;      break;
325    case tcons:    case tcons:
326      if(fprintf(stream, "[ ") < 0){      if(fprintf(stream, "[ ") < 0) {
       perror("print_val");  
327        env->err= 5;        env->err= 5;
328        return;        return printerr(env);
329      }      }
330      tstack= stack;      tstack= stack;
331    
# Line 509  void print_val(environment *env, value * Line 347  void print_val(environment *env, value *
347    
348        if(titem != NULL){        /* If we found it on the stack, */        if(titem != NULL){        /* If we found it on the stack, */
349          if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */          if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
           perror("print_val");  
350            env->err= 5;            env->err= 5;
351            free(titem);            free(titem);
352            return;            return printerr(env);
353          }          }
354        } else {        } else {
355          print_val(env, CAR(val), noquote, tstack, stream);          print_val(env, CAR(val), noquote, tstack, stream);
# Line 534  void print_val(environment *env, value * Line 371  void print_val(environment *env, value *
371          }          }
372          if(titem != NULL){      /* If we found it on the stack, */          if(titem != NULL){      /* If we found it on the stack, */
373            if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */            if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
             perror("print_val");  
374              env->err= 5;              env->err= 5;
375                printerr(env);
376              goto printval_end;              goto printval_end;
377            }            }
378          } else {          } else {
379            if(fprintf(stream, " ") < 0){            if(fprintf(stream, " ") < 0){
             perror("print_val");  
380              env->err= 5;              env->err= 5;
381                printerr(env);
382              goto printval_end;              goto printval_end;
383            }            }
384          }          }
385          break;          break;
386        default:        default:
387          if(fprintf(stream, " . ") < 0){ /* Improper list */          if(fprintf(stream, " . ") < 0){ /* Improper list */
           perror("print_val");  
388            env->err= 5;            env->err= 5;
389              printerr(env);
390            goto printval_end;            goto printval_end;
391          }          }
392          print_val(env, val, noquote, tstack, stream);          print_val(env, val, noquote, tstack, stream);
# Line 567  void print_val(environment *env, value * Line 404  void print_val(environment *env, value *
404    
405      if(! (env->err)){      if(! (env->err)){
406        if(fprintf(stream, " ]") < 0){        if(fprintf(stream, " ]") < 0){
         perror("print_val");  
407          env->err= 5;          env->err= 5;
408        }        }
409      }      }
410      break;      break;
411    }    }
412      
413      if(env->err)
414        return printerr(env);
415  }  }
416    
417    
# Line 580  void print_val(environment *env, value * Line 419  void print_val(environment *env, value *
419  extern void swap(environment *env)  extern void swap(environment *env)
420  {  {
421    value *temp= env->head;    value *temp= env->head;
     
   if(env->head->type == empty || CDR(env->head)->type == empty) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
422    
423      if(check_args(env, 2, unknown, unknown))
424        return printerr(env);
425      
426    env->head= CDR(env->head);    env->head= CDR(env->head);
427    CDR(temp)= CDR(env->head);    CDR(temp)= CDR(env->head);
428    CDR(env->head)= temp;    CDR(env->head)= temp;
# Line 598  extern void rcl(environment *env) Line 434  extern void rcl(environment *env)
434  {  {
435    value *val;    value *val;
436    
437    if(env->head->type==empty) {    if(check_args(env, 1, symb))
438      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
439    
440    val= CAR(env->head)->content.sym->val;    val= CAR(env->head)->content.sym->val;
441    if(val == NULL){    if(val == NULL){
     printerr("Unbound Variable");  
442      env->err= 3;      env->err= 3;
443      return;      return printerr(env);
444    }    }
445    
446    push_val(env, val);           /* Return the symbol's bound value */    push_val(env, val);           /* Return the symbol's bound value */
447    swap(env);    swap(env);
448    if(env->err) return;    if(env->err) return;
# Line 636  extern void eval(environment *env) Line 463  extern void eval(environment *env)
463    
464    gc_maybe(env);    gc_maybe(env);
465    
466    if(env->head->type==empty) {    if(check_args(env, 1, unknown))
467      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
468    
469    switch(CAR(env->head)->type) {    switch(CAR(env->head)->type) {
470      /* if it's a symbol */      /* if it's a symbol */
471    case symb:    case symb:
472        env->errsymb= CAR(env->head)->content.sym->id;
473      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
474      if(env->err) return;      if(env->err) return;
475      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
# Line 656  extern void eval(environment *env) Line 481  extern void eval(environment *env)
481    case func:    case func:
482      in_func= CAR(env->head)->content.func;      in_func= CAR(env->head)->content.func;
483      env->head= CDR(env->head);      env->head= CDR(env->head);
484      return in_func(env);      return in_func((void*)env);
485    
486      /* If it's a list */      /* If it's a list */
487    case tcons:    case tcons:
# Line 682  extern void eval(environment *env) Line 507  extern void eval(environment *env)
507        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
508          iterator= CDR(iterator);          iterator= CDR(iterator);
509        else {        else {
510          printerr("Bad Argument Type"); /* Improper list */          env->err= 2; /* Improper list */
511          env->err= 2;          return printerr(env);
         return;  
512        }        }
513      }      }
514      unprotect(temp_val);      unprotect(temp_val);
# Line 696  extern void eval(environment *env) Line 520  extern void eval(environment *env)
520    case tfloat:    case tfloat:
521    case string:    case string:
522    case port:    case port:
523      case unknown:
524      return;      return;
525    }    }
526  }  }
# Line 752  int main(int argc, char **argv) Line 577  int main(int argc, char **argv)
577    }    }
578    
579    if(myenv.interactive)    if(myenv.interactive)
580      printf(start_message);      puts(start_message);
581    
582    while(1) {    while(1) {
583      if(myenv.in_string==NULL) {      if(myenv.in_string==NULL) {
# Line 803  value *copy_val(environment *env, value Line 628  value *copy_val(environment *env, value
628    case func:    case func:
629    case symb:    case symb:
630    case empty:    case empty:
631      case unknown:
632    case port:    case port:
633      new_value->content= old_value->content;      new_value->content= old_value->content;
634      break;      break;
# Line 832  void readlinestream(environment *env, FI Line 658  void readlinestream(environment *env, FI
658    if(fgets(in_string, 100, stream)==NULL) {    if(fgets(in_string, 100, stream)==NULL) {
659      push_cstring(env, "");      push_cstring(env, "");
660      if (! feof(stream)){      if (! feof(stream)){
       perror("readline");  
661        env->err= 5;        env->err= 5;
662          return printerr(env);
663      }      }
664    } else {    } else {
665      push_cstring(env, in_string);      push_cstring(env, in_string);
# Line 846  extern void rev(environment *env) Line 672  extern void rev(environment *env)
672  {  {
673    value *old_head, *new_head, *item;    value *old_head, *new_head, *item;
674    
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
675    if(CAR(env->head)->type==empty)    if(CAR(env->head)->type==empty)
676      return;                     /* Don't reverse an empty list */      return;                     /* Don't reverse an empty list */
677    
678    if(CAR(env->head)->type!=tcons) {    if(check_args(env, 1, tcons))
679      printerr("Bad Argument Type");      return printerr(env);
     env->err= 2;  
     return;  
   }  
680    
681    old_head= CAR(env->head);    old_head= CAR(env->head);
682    new_head= new_val(env);    new_head= new_val(env);
# Line 996  void readstream(environment *env, FILE * Line 813  void readstream(environment *env, FILE *
813    if(depth)    if(depth)
814      return readstream(env, env->inputstream);      return readstream(env, env->inputstream);
815  }  }
816    
817    
818    int check_args(environment *env, int num_args, ...)
819    {
820      va_list ap;
821      enum type_enum mytype;
822      int i;
823    
824      value *iter= env->head;
825      int errval= 0;
826    
827      va_start(ap, num_args);
828      for(i=1; i<=num_args; i++) {
829        mytype= va_arg(ap, enum type_enum);
830        //    fprintf(stderr, "%s\n", env->errsymb);
831    
832        if(iter->type==empty || iter==NULL) {
833          errval= 1;
834          break;
835        }
836    
837        if(mytype!=unknown && CAR(iter)->type!=mytype) {
838          errval= 2;
839          break;
840        }
841    
842        iter= CDR(iter);
843      }
844    
845      va_end(ap);
846    
847      env->err= errval;
848      return errval;
849    }
Legend:
Removed from v.1.132  
changed lines
  Added in v.1.137
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26