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

Diff of /stack/stack.c

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

revision 1.134 by masse, Wed Aug 13 06:12:26 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(environment *env, const char* in_string)  void printerr(environment *env)
54  {  {
55      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);    fprintf(stderr, "\"%s\":\nErr: %s\n", env->errsymb, in_string);
77  }  }
78    
# Line 425  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)
       perror("print_val");  
450        env->err= 5;        env->err= 5;
       return;  
     }  
451      break;      break;
452    case unknown:    case unknown:
453      if(fprintf(stream, "UNKNOWN") < 0){      if(fprintf(stream, "UNKNOWN") < 0)
       perror("print_val");  
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 514  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 539  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 572  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 586  extern void swap(environment *env) Line 580  extern void swap(environment *env)
580  {  {
581    value *temp= env->head;    value *temp= env->head;
582    
583    switch(check_args(env, unknown, unknown, empty)) {    if(check_args(env, 2, unknown, unknown))
584    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
585        
586    env->head= CDR(env->head);    env->head= CDR(env->head);
587    CDR(temp)= CDR(env->head);    CDR(temp)= CDR(env->head);
# Line 608  extern void rcl(environment *env) Line 594  extern void rcl(environment *env)
594  {  {
595    value *val;    value *val;
596    
597    switch(check_args(env, symb, empty)) {    if(check_args(env, 1, symb))
598    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
599    
600    val= CAR(env->head)->content.sym->val;    val= CAR(env->head)->content.sym->val;
601    if(val == NULL){    if(val == NULL){
     printerr(env, "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 645  extern void eval(environment *env) Line 623  extern void eval(environment *env)
623    
624    gc_maybe(env);    gc_maybe(env);
625    
626    switch(check_args(env, unknown, empty)) {    if(check_args(env, 1, unknown))
627    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
628    
629    switch(CAR(env->head)->type) {    switch(CAR(env->head)->type) {
630      /* if it's a symbol */      /* if it's a symbol */
# Line 671  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 697  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(env, "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 849  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 866  extern void rev(environment *env) Line 835  extern void rev(environment *env)
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    switch(check_args(env, tcons, empty)) {    if(check_args(env, 1, tcons))
839    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
840    
841    old_head= CAR(env->head);    old_head= CAR(env->head);
842    new_head= new_val(env);    new_head= new_val(env);
# Line 1014  void readstream(environment *env, FILE * Line 975  void readstream(environment *env, FILE *
975  }  }
976    
977    
978  int check_args(environment *env, ...)  int check_args(environment *env, int num_args, ...)
979  {  {
980    va_list ap;    va_list ap;
981    enum type_enum mytype;    enum type_enum mytype;
982      int i;
983    
984    value *iter= env->head;    value *iter= env->head;
985    int errval= 0;    int errval= 0;
986    
987    va_start(ap, env);    va_start(ap, num_args);
988    while(1) {    for(i=1; i<=num_args; i++) {
989      mytype= va_arg(ap, enum type_enum);      mytype= va_arg(ap, enum type_enum);
990      //    fprintf(stderr, "%s\n", env->errsymb);      //    fprintf(stderr, "%s\n", env->errsymb);
991    
     if(mytype==empty)  
       break;  
       
992      if(iter->type==empty || iter==NULL) {      if(iter->type==empty || iter==NULL) {
993        errval= 1;        errval= 1;
994        break;        break;
995      }      }
996    
997      if(mytype==unknown) {      if(mytype!=unknown && CAR(iter)->type!=mytype) {
       iter=CDR(iter);  
       continue;  
     }  
   
     if(CAR(iter)->type!=mytype) {  
998        errval= 2;        errval= 2;
999        break;        break;
1000      }      }
Legend:
Removed from v.1.134  
changed lines
  Added in v.1.136
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26