/[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.135 by masse, Wed Aug 13 11:58:00 2003 UTC
# 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      default:
70        in_string= "Unknown error";
71        break;
72      }
73    
74      fprintf(stderr, "\"%s\":\nErr: %s\n", env->errsymb, in_string);
75  }  }
76    
77    
# Line 167  extern void gc_init(environment *env) Line 186  extern void gc_init(environment *env)
186          break;          break;
187        case port:        case port:
188        case empty:        case empty:
189          case unknown:
190        case integer:        case integer:
191        case tfloat:        case tfloat:
192        case func:        case func:
# Line 364  void push_sym(environment *env, const ch Line 384  void push_sym(environment *env, const ch
384    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
385    
386    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
387    new_fvalue= new_val(env);    new_fvalue= new_val(env);
   protect(new_fvalue);  
388    
389    /* The new value is a symbol */    /* The new value is a symbol */
390    new_value->type= symb;    new_value->type= symb;
# Line 414  void push_sym(environment *env, const ch Line 432  void push_sym(environment *env, const ch
432    }    }
433    
434    push_val(env, new_value);    push_val(env, new_value);
   unprotect(new_value); unprotect(new_fvalue);  
435  }  }
436    
437    
# Line 433  void print_val(environment *env, value * Line 450  void print_val(environment *env, value *
450        return;        return;
451      }      }
452      break;      break;
453      case unknown:
454        if(fprintf(stream, "UNKNOWN") < 0){
455          perror("print_val");
456          env->err= 5;
457          return;
458        }
459        break;
460    case integer:    case integer:
461      if(fprintf(stream, "%d", val->content.i) < 0){      if(fprintf(stream, "%d", val->content.i) < 0){
462        perror("print_val");        perror("print_val");
# Line 580  void print_val(environment *env, value * Line 604  void print_val(environment *env, value *
604  extern void swap(environment *env)  extern void swap(environment *env)
605  {  {
606    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;  
   }  
607    
608      if(check_args(env, unknown, unknown, empty))
609        return printerr(env);
610      
611    env->head= CDR(env->head);    env->head= CDR(env->head);
612    CDR(temp)= CDR(env->head);    CDR(temp)= CDR(env->head);
613    CDR(env->head)= temp;    CDR(env->head)= temp;
# Line 598  extern void rcl(environment *env) Line 619  extern void rcl(environment *env)
619  {  {
620    value *val;    value *val;
621    
622    if(env->head->type==empty) {    if(check_args(env, symb, empty))
623      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;  
   }  
624    
625    val= CAR(env->head)->content.sym->val;    val= CAR(env->head)->content.sym->val;
626    if(val == NULL){    if(val == NULL){
     printerr("Unbound Variable");  
627      env->err= 3;      env->err= 3;
628      return;      return printerr(env);
629    }    }
630    
631    push_val(env, val);           /* Return the symbol's bound value */    push_val(env, val);           /* Return the symbol's bound value */
632    swap(env);    swap(env);
633    if(env->err) return;    if(env->err) return;
# Line 636  extern void eval(environment *env) Line 648  extern void eval(environment *env)
648    
649    gc_maybe(env);    gc_maybe(env);
650    
651    if(env->head->type==empty) {    if(check_args(env, unknown, empty))
652      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
653    
654    switch(CAR(env->head)->type) {    switch(CAR(env->head)->type) {
655      /* if it's a symbol */      /* if it's a symbol */
656    case symb:    case symb:
657        env->errsymb= CAR(env->head)->content.sym->id;
658      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
659      if(env->err) return;      if(env->err) return;
660      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 666  extern void eval(environment *env)
666    case func:    case func:
667      in_func= CAR(env->head)->content.func;      in_func= CAR(env->head)->content.func;
668      env->head= CDR(env->head);      env->head= CDR(env->head);
669      return in_func(env);      return in_func((void*)env);
670    
671      /* If it's a list */      /* If it's a list */
672    case tcons:    case tcons:
# Line 682  extern void eval(environment *env) Line 692  extern void eval(environment *env)
692        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
693          iterator= CDR(iterator);          iterator= CDR(iterator);
694        else {        else {
695          printerr("Bad Argument Type"); /* Improper list */          env->err= 2; /* Improper list */
696          env->err= 2;          return printerr(env);
         return;  
697        }        }
698      }      }
699      unprotect(temp_val);      unprotect(temp_val);
# Line 696  extern void eval(environment *env) Line 705  extern void eval(environment *env)
705    case tfloat:    case tfloat:
706    case string:    case string:
707    case port:    case port:
708      case unknown:
709      return;      return;
710    }    }
711  }  }
# Line 752  int main(int argc, char **argv) Line 762  int main(int argc, char **argv)
762    }    }
763    
764    if(myenv.interactive)    if(myenv.interactive)
765      printf(start_message);      puts(start_message);
766    
767    while(1) {    while(1) {
768      if(myenv.in_string==NULL) {      if(myenv.in_string==NULL) {
# Line 803  value *copy_val(environment *env, value Line 813  value *copy_val(environment *env, value
813    case func:    case func:
814    case symb:    case symb:
815    case empty:    case empty:
816      case unknown:
817    case port:    case port:
818      new_value->content= old_value->content;      new_value->content= old_value->content;
819      break;      break;
# Line 846  extern void rev(environment *env) Line 857  extern void rev(environment *env)
857  {  {
858    value *old_head, *new_head, *item;    value *old_head, *new_head, *item;
859    
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
860    if(CAR(env->head)->type==empty)    if(CAR(env->head)->type==empty)
861      return;                     /* Don't reverse an empty list */      return;                     /* Don't reverse an empty list */
862    
863    if(CAR(env->head)->type!=tcons) {    if(check_args(env, tcons, empty))
864      printerr("Bad Argument Type");      return printerr(env);
     env->err= 2;  
     return;  
   }  
865    
866    old_head= CAR(env->head);    old_head= CAR(env->head);
867    new_head= new_val(env);    new_head= new_val(env);
# Line 996  void readstream(environment *env, FILE * Line 998  void readstream(environment *env, FILE *
998    if(depth)    if(depth)
999      return readstream(env, env->inputstream);      return readstream(env, env->inputstream);
1000  }  }
1001    
1002    
1003    int check_args(environment *env, ...)
1004    {
1005      va_list ap;
1006      enum type_enum mytype;
1007    
1008      value *iter= env->head;
1009      int errval= 0;
1010    
1011      va_start(ap, env);
1012      while(1) {
1013        mytype= va_arg(ap, enum type_enum);
1014        //    fprintf(stderr, "%s\n", env->errsymb);
1015    
1016        if(mytype==empty)
1017          break;
1018        
1019        if(iter->type==empty || iter==NULL) {
1020          errval= 1;
1021          break;
1022        }
1023    
1024        if(mytype==unknown) {
1025          iter=CDR(iter);
1026          continue;
1027        }
1028    
1029        if(CAR(iter)->type!=mytype) {
1030          errval= 2;
1031          break;
1032        }
1033    
1034        iter= CDR(iter);
1035      }
1036    
1037      va_end(ap);
1038    
1039      env->err= errval;
1040      return errval;
1041    }
Legend:
Removed from v.1.132  
changed lines
  Added in v.1.135
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26