/[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.136 by masse, Mon Aug 18 14:39:16 2003 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 167  extern void gc_init(environment *env) Line 188  extern void gc_init(environment *env)
188          break;          break;
189        case port:        case port:
190        case empty:        case empty:
191          case unknown:
192        case integer:        case integer:
193        case tfloat:        case tfloat:
194        case func:        case func:
# Line 364  void push_sym(environment *env, const ch Line 386  void push_sym(environment *env, const ch
386    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
387    
388    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
389    new_fvalue= new_val(env);    new_fvalue= new_val(env);
   protect(new_fvalue);  
390    
391    /* The new value is a symbol */    /* The new value is a symbol */
392    new_value->type= symb;    new_value->type= symb;
# Line 414  void push_sym(environment *env, const ch Line 434  void push_sym(environment *env, const ch
434    }    }
435    
436    push_val(env, new_value);    push_val(env, new_value);
   unprotect(new_value); unprotect(new_fvalue);  
437  }  }
438    
439    
# Line 427  void print_val(environment *env, value * Line 446  void print_val(environment *env, value *
446    
447    switch(val->type) {    switch(val->type) {
448    case empty:    case empty:
449      if(fprintf(stream, "[]") < 0){      if(fprintf(stream, "[]") < 0)
450        perror("print_val");        env->err= 5;
451        break;
452      case unknown:
453        if(fprintf(stream, "UNKNOWN") < 0)
454        env->err= 5;        env->err= 5;
       return;  
     }  
455      break;      break;
456    case integer:    case integer:
457      if(fprintf(stream, "%d", val->content.i) < 0){      if(fprintf(stream, "%d", val->content.i) < 0)
       perror("print_val");  
458        env->err= 5;        env->err= 5;
       return;  
     }  
459      break;      break;
460    case tfloat:    case tfloat:
461      if(fprintf(stream, "%f", val->content.f) < 0){      if(fprintf(stream, "%f", val->content.f) < 0)
       perror("print_val");  
462        env->err= 5;        env->err= 5;
       return;  
     }  
463      break;      break;
464    case string:    case string:
465      if(noquote){      if(noquote){
466        if(fprintf(stream, "%s", val->content.string) < 0){        if(fprintf(stream, "%s", val->content.string) < 0)
         perror("print_val");  
467          env->err= 5;          env->err= 5;
         return;  
       }  
468      } else {                    /* quote */      } else {                    /* quote */
469        if(fprintf(stream, "\"%s\"", val->content.string) < 0){        if(fprintf(stream, "\"%s\"", val->content.string) < 0)
         perror("print_val");  
470          env->err= 5;          env->err= 5;
         return;  
       }  
471      }      }
472      break;      break;
473    case symb:    case symb:
474      if(fprintf(stream, "%s", val->content.sym->id) < 0){      if(fprintf(stream, "%s", val->content.sym->id) < 0)
       perror("print_val");  
475        env->err= 5;        env->err= 5;
       return;  
     }  
476      break;      break;
477    case func:    case func:
478      if(fprintf(stream, "#<function %p>", val->content.func) < 0){      if(fprintf(stream, "#<function %p>", val->content.func) < 0)
       perror("print_val");  
479        env->err= 5;        env->err= 5;
       return;  
     }  
480      break;      break;
481    case port:    case port:
482      if(fprintf(stream, "#<port %p>", val->content.p) < 0){      if(fprintf(stream, "#<port %p>", val->content.p) < 0)
       perror("print_val");  
483        env->err= 5;        env->err= 5;
       return;  
     }  
484      break;      break;
485    case tcons:    case tcons:
486      if(fprintf(stream, "[ ") < 0){      if(fprintf(stream, "[ ") < 0) {
       perror("print_val");  
487        env->err= 5;        env->err= 5;
488        return;        return printerr(env);
489      }      }
490      tstack= stack;      tstack= stack;
491    
# Line 509  void print_val(environment *env, value * Line 507  void print_val(environment *env, value *
507    
508        if(titem != NULL){        /* If we found it on the stack, */        if(titem != NULL){        /* If we found it on the stack, */
509          if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */          if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
           perror("print_val");  
510            env->err= 5;            env->err= 5;
511            free(titem);            free(titem);
512            return;            return printerr(env);
513          }          }
514        } else {        } else {
515          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 531  void print_val(environment *env, value *
531          }          }
532          if(titem != NULL){      /* If we found it on the stack, */          if(titem != NULL){      /* If we found it on the stack, */
533            if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */            if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
             perror("print_val");  
534              env->err= 5;              env->err= 5;
535                printerr(env);
536              goto printval_end;              goto printval_end;
537            }            }
538          } else {          } else {
539            if(fprintf(stream, " ") < 0){            if(fprintf(stream, " ") < 0){
             perror("print_val");  
540              env->err= 5;              env->err= 5;
541                printerr(env);
542              goto printval_end;              goto printval_end;
543            }            }
544          }          }
545          break;          break;
546        default:        default:
547          if(fprintf(stream, " . ") < 0){ /* Improper list */          if(fprintf(stream, " . ") < 0){ /* Improper list */
           perror("print_val");  
548            env->err= 5;            env->err= 5;
549              printerr(env);
550            goto printval_end;            goto printval_end;
551          }          }
552          print_val(env, val, noquote, tstack, stream);          print_val(env, val, noquote, tstack, stream);
# Line 567  void print_val(environment *env, value * Line 564  void print_val(environment *env, value *
564    
565      if(! (env->err)){      if(! (env->err)){
566        if(fprintf(stream, " ]") < 0){        if(fprintf(stream, " ]") < 0){
         perror("print_val");  
567          env->err= 5;          env->err= 5;
568        }        }
569      }      }
570      break;      break;
571    }    }
572      
573      if(env->err)
574        return printerr(env);
575  }  }
576    
577    
# Line 580  void print_val(environment *env, value * Line 579  void print_val(environment *env, value *
579  extern void swap(environment *env)  extern void swap(environment *env)
580  {  {
581    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;  
   }  
582    
583      if(check_args(env, 2, unknown, unknown))
584        return printerr(env);
585      
586    env->head= CDR(env->head);    env->head= CDR(env->head);
587    CDR(temp)= CDR(env->head);    CDR(temp)= CDR(env->head);
588    CDR(env->head)= temp;    CDR(env->head)= temp;
# Line 598  extern void rcl(environment *env) Line 594  extern void rcl(environment *env)
594  {  {
595    value *val;    value *val;
596    
597    if(env->head->type==empty) {    if(check_args(env, 1, symb))
598      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;  
   }  
599    
600    val= CAR(env->head)->content.sym->val;    val= CAR(env->head)->content.sym->val;
601    if(val == NULL){    if(val == NULL){
     printerr("Unbound Variable");  
602      env->err= 3;      env->err= 3;
603      return;      return printerr(env);
604    }    }
605    
606    push_val(env, val);           /* Return the symbol's bound value */    push_val(env, val);           /* Return the symbol's bound value */
607    swap(env);    swap(env);
608    if(env->err) return;    if(env->err) return;
# Line 636  extern void eval(environment *env) Line 623  extern void eval(environment *env)
623    
624    gc_maybe(env);    gc_maybe(env);
625    
626    if(env->head->type==empty) {    if(check_args(env, 1, unknown))
627      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
628    
629    switch(CAR(env->head)->type) {    switch(CAR(env->head)->type) {
630      /* if it's a symbol */      /* if it's a symbol */
631    case symb:    case symb:
632        env->errsymb= CAR(env->head)->content.sym->id;
633      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
634      if(env->err) return;      if(env->err) return;
635      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 641  extern void eval(environment *env)
641    case func:    case func:
642      in_func= CAR(env->head)->content.func;      in_func= CAR(env->head)->content.func;
643      env->head= CDR(env->head);      env->head= CDR(env->head);
644      return in_func(env);      return in_func((void*)env);
645    
646      /* If it's a list */      /* If it's a list */
647    case tcons:    case tcons:
# Line 682  extern void eval(environment *env) Line 667  extern void eval(environment *env)
667        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
668          iterator= CDR(iterator);          iterator= CDR(iterator);
669        else {        else {
670          printerr("Bad Argument Type"); /* Improper list */          env->err= 2; /* Improper list */
671          env->err= 2;          return printerr(env);
         return;  
672        }        }
673      }      }
674      unprotect(temp_val);      unprotect(temp_val);
# Line 696  extern void eval(environment *env) Line 680  extern void eval(environment *env)
680    case tfloat:    case tfloat:
681    case string:    case string:
682    case port:    case port:
683      case unknown:
684      return;      return;
685    }    }
686  }  }
# Line 752  int main(int argc, char **argv) Line 737  int main(int argc, char **argv)
737    }    }
738    
739    if(myenv.interactive)    if(myenv.interactive)
740      printf(start_message);      puts(start_message);
741    
742    while(1) {    while(1) {
743      if(myenv.in_string==NULL) {      if(myenv.in_string==NULL) {
# Line 803  value *copy_val(environment *env, value Line 788  value *copy_val(environment *env, value
788    case func:    case func:
789    case symb:    case symb:
790    case empty:    case empty:
791      case unknown:
792    case port:    case port:
793      new_value->content= old_value->content;      new_value->content= old_value->content;
794      break;      break;
# Line 832  void readlinestream(environment *env, FI Line 818  void readlinestream(environment *env, FI
818    if(fgets(in_string, 100, stream)==NULL) {    if(fgets(in_string, 100, stream)==NULL) {
819      push_cstring(env, "");      push_cstring(env, "");
820      if (! feof(stream)){      if (! feof(stream)){
       perror("readline");  
821        env->err= 5;        env->err= 5;
822          return printerr(env);
823      }      }
824    } else {    } else {
825      push_cstring(env, in_string);      push_cstring(env, in_string);
# Line 846  extern void rev(environment *env) Line 832  extern void rev(environment *env)
832  {  {
833    value *old_head, *new_head, *item;    value *old_head, *new_head, *item;
834    
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
835    if(CAR(env->head)->type==empty)    if(CAR(env->head)->type==empty)
836      return;                     /* Don't reverse an empty list */      return;                     /* Don't reverse an empty list */
837    
838    if(CAR(env->head)->type!=tcons) {    if(check_args(env, 1, tcons))
839      printerr("Bad Argument Type");      return printerr(env);
     env->err= 2;  
     return;  
   }  
840    
841    old_head= CAR(env->head);    old_head= CAR(env->head);
842    new_head= new_val(env);    new_head= new_val(env);
# Line 996  void readstream(environment *env, FILE * Line 973  void readstream(environment *env, FILE *
973    if(depth)    if(depth)
974      return readstream(env, env->inputstream);      return readstream(env, env->inputstream);
975  }  }
976    
977    
978    int check_args(environment *env, int num_args, ...)
979    {
980      va_list ap;
981      enum type_enum mytype;
982      int i;
983    
984      value *iter= env->head;
985      int errval= 0;
986    
987      va_start(ap, num_args);
988      for(i=1; i<=num_args; i++) {
989        mytype= va_arg(ap, enum type_enum);
990        //    fprintf(stderr, "%s\n", env->errsymb);
991    
992        if(iter->type==empty || iter==NULL) {
993          errval= 1;
994          break;
995        }
996    
997        if(mytype!=unknown && CAR(iter)->type!=mytype) {
998          errval= 2;
999          break;
1000        }
1001    
1002        iter= CDR(iter);
1003      }
1004    
1005      va_end(ap);
1006    
1007      env->err= errval;
1008      return errval;
1009    }
Legend:
Removed from v.1.132  
changed lines
  Added in v.1.136
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26