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

Diff of /stack/stack.c

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

revision 1.112 by teddy, Sat Mar 16 20:09:51 2002 UTC revision 1.114 by teddy, Sun Mar 17 02:15:01 2002 UTC
# Line 20  Line 20 
20               Teddy Hogeborn <teddy@fukt.bth.se>               Teddy Hogeborn <teddy@fukt.bth.se>
21  */  */
22    
23  #define CAR(X) X->content.c->car  #define CAR(X) (X->content.c->car)
24  #define CDR(X) X->content.c->cdr  #define CDR(X) (X->content.c->cdr)
25    
26  /* printf, sscanf, fgets, fprintf, fopen, perror */  /* printf, sscanf, fgets, fprintf, fopen, perror */
27  #include <stdio.h>  #include <stdio.h>
# Line 233  extern void gc_init(environment *env) Line 233  extern void gc_init(environment *env)
233      /* Keep values */          /* Keep values */    
234      env->gc_count += sizeof(value);      env->gc_count += sizeof(value);
235      if(env->gc_ref->item->type==string)      if(env->gc_ref->item->type==string)
236        env->gc_count += strlen(env->gc_ref->item->content.ptr);        env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
237            
238      titem= env->gc_ref->next;      titem= env->gc_ref->next;
239      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
# Line 476  extern void type(environment *env) Line 476  extern void type(environment *env)
476      push_sym(env, "function");      push_sym(env, "function");
477      break;      break;
478    case tcons:    case tcons:
479      push_sym(env, "list");      push_sym(env, "pair");
480      break;      break;
481    }    }
482    swap(env);    swap(env);
# Line 484  extern void type(environment *env) Line 484  extern void type(environment *env)
484    toss(env);    toss(env);
485  }      }    
486    
487  /* Prints the top element of the stack. */  /* Print a value */
488  void print_h(value *stack_head, int noquote)  void print_val(value *val, int noquote)
489  {  {
490    switch(CAR(stack_head)->type) {    switch(val->type) {
491    case empty:    case empty:
492      printf("[]");      printf("[]");
493      break;      break;
494    case integer:    case integer:
495      printf("%d", CAR(stack_head)->content.i);      printf("%d", val->content.i);
496      break;      break;
497    case tfloat:    case tfloat:
498      printf("%f", CAR(stack_head)->content.f);      printf("%f", val->content.f);
499      break;      break;
500    case string:    case string:
501      if(noquote)      if(noquote)
502        printf("%s", (char*)(CAR(stack_head)->content.ptr));        printf("%s", (char*)(val->content.ptr));
503      else      else
504        printf("\"%s\"", (char*)(CAR(stack_head)->content.ptr));        printf("\"%s\"", (char*)(val->content.ptr));
505      break;      break;
506    case symb:    case symb:
507      printf("%s", CAR(stack_head)->content.sym->id);      printf("%s", val->content.sym->id);
508      break;      break;
509    case func:    case func:
510      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));      printf("#<function %p>", (funcp)(val->content.ptr));
511      break;      break;
512    case tcons:    case tcons:
     /* A list is just a stack, so make stack_head point to it */  
     stack_head= CAR(stack_head);  
513      printf("[ ");      printf("[ ");
514      while(stack_head->type != empty) {      do {
515        print_h(stack_head, noquote);        print_val(CAR(val), noquote);
516        switch(CDR(stack_head)->type){        val= CDR(val);
517          switch(val->type){
518        case empty:        case empty:
519          break;          break;
520        case tcons:        case tcons:
# Line 523  void print_h(value *stack_head, int noqu Line 522  void print_h(value *stack_head, int noqu
522          break;          break;
523        default:        default:
524          printf(" . ");          /* Improper list */          printf(" . ");          /* Improper list */
525            print_val(val, noquote);
526        }        }
527        stack_head= CDR(stack_head);      } while(val->type == tcons);
     }  
528      printf(" ]");      printf(" ]");
529      break;      break;
530    }    }
# Line 538  extern void print_(environment *env) Line 537  extern void print_(environment *env)
537      env->err= 1;      env->err= 1;
538      return;      return;
539    }    }
540    print_h(env->head, 0);    print_val(CAR(env->head), 0);
541    nl();    nl();
542  }  }
543    
# Line 557  extern void princ_(environment *env) Line 556  extern void princ_(environment *env)
556      env->err= 1;      env->err= 1;
557      return;      return;
558    }    }
559    print_h(env->head, 1);    print_val(CAR(env->head), 1);
560  }  }
561    
562  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack and then discards it. */
# Line 574  void print_st(value *stack_head, long co Line 573  void print_st(value *stack_head, long co
573    if(CDR(stack_head)->type != empty)    if(CDR(stack_head)->type != empty)
574      print_st(CDR(stack_head), counter+1);      print_st(CDR(stack_head), counter+1);
575    printf("%ld: ", counter);    printf("%ld: ", counter);
576    print_h(stack_head, 0);    print_val(CAR(stack_head), 0);
577    nl();    nl();
578  }  }
579    
# Line 1726  extern void sx_72656164(environment *env Line 1725  extern void sx_72656164(environment *env
1725      } else {      } else {
1726        push_float(env, ftemp);        push_float(env, ftemp);
1727      }      }
1728      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1729                && readlength != -1) {
1730        push_cstring(env, "");
1731    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1732              && readlength != -1) {              && readlength != -1) {
1733      push_cstring(env, match);      push_cstring(env, match);
# Line 2281  extern void sx_646976(environment *env) Line 2283  extern void sx_646976(environment *env)
2283    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2284    env->err= 2;    env->err= 2;
2285  }  }
2286    
2287    extern void setcar(environment *env)
2288    {
2289      if(env->head->type==empty || CDR(env->head)->type==empty) {
2290        printerr("Too Few Arguments");
2291        env->err= 1;
2292        return;
2293      }
2294    
2295      if(CDR(env->head)->type!=tcons) {
2296        printerr("Bad Argument Type");
2297        env->err= 2;
2298        return;
2299      }
2300    
2301      CAR(CAR(CDR(env->head)))=CAR(env->head);
2302      toss(env);
2303    }
2304    
2305    extern void setcdr(environment *env)
2306    {
2307      if(env->head->type==empty || CDR(env->head)->type==empty) {
2308        printerr("Too Few Arguments");
2309        env->err= 1;
2310        return;
2311      }
2312    
2313      if(CDR(env->head)->type!=tcons) {
2314        printerr("Bad Argument Type");
2315        env->err= 2;
2316        return;
2317      }
2318    
2319      CDR(CAR(CDR(env->head)))=CAR(env->head);
2320      toss(env);
2321    }
2322    
2323    extern void car(environment *env)
2324    {
2325      if(env->head->type==empty) {
2326        printerr("Too Few Arguments");
2327        env->err= 1;
2328        return;
2329      }
2330    
2331      if(CAR(env->head)->type!=tcons) {
2332        printerr("Bad Argument Type");
2333        env->err= 2;
2334        return;
2335      }
2336    
2337      CAR(env->head)=CAR(CAR(env->head));
2338    }
2339    
2340    extern void cdr(environment *env)
2341    {
2342      if(env->head->type==empty) {
2343        printerr("Too Few Arguments");
2344        env->err= 1;
2345        return;
2346      }
2347    
2348      if(CAR(env->head)->type!=tcons) {
2349        printerr("Bad Argument Type");
2350        env->err= 2;
2351        return;
2352      }
2353    
2354      CAR(env->head)=CDR(CAR(env->head));
2355    }
Legend:
Removed from v.1.112  
changed lines
  Added in v.1.114
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26