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

Diff of /stack/stack.c

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

revision 1.111 by teddy, Sat Mar 16 19:09:54 2002 UTC revision 1.115 by teddy, Sun Mar 17 11:26:35 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 165  inline void gc_maybe(environment *env) Line 165  inline void gc_maybe(environment *env)
165  extern void gc_init(environment *env)  extern void gc_init(environment *env)
166  {  {
167    stackitem *new_head= NULL, *titem;    stackitem *new_head= NULL, *titem;
168    cons *iterator;    pair *iterator;
169    symbol *tsymb;    symbol *tsymb;
170    int i;    int i;
171    
# 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 285  void push_val(environment *env, value *v Line 285  void push_val(environment *env, value *v
285  {  {
286    value *new_value= new_val(env);    value *new_value= new_val(env);
287    
288    new_value->content.c= malloc(sizeof(cons));    new_value->content.c= malloc(sizeof(pair));
289    assert(new_value->content.c!=NULL);    assert(new_value->content.c!=NULL);
290    new_value->type= tcons;    new_value->type= tcons;
291    CAR(new_value)= val;    CAR(new_value)= val;
# Line 450  extern void nl() Line 450  extern void nl()
450  /* Gets the type of a value */  /* Gets the type of a value */
451  extern void type(environment *env)  extern void type(environment *env)
452  {  {
   int typenum;  
   
453    if(env->head->type==empty) {    if(env->head->type==empty) {
454      printerr("Too Few Arguments");      printerr("Too Few Arguments");
455      env->err= 1;      env->err= 1;
456      return;      return;
457    }    }
458    
459    typenum= CAR(env->head)->type;    switch(CAR(env->head)->type){
460    toss(env);    case empty:
461    switch(typenum){      push_sym(env, "empty");
462        break;
463    case integer:    case integer:
464      push_sym(env, "integer");      push_sym(env, "integer");
465      break;      break;
# Line 477  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);
483      if (env->err) return;
484      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:
492        printf("[]");
493        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(CAR(stack_head)->type != empty) {      do {
515        print_h(stack_head, noquote);        print_val(CAR(val), noquote);
516        if(CDR(stack_head)->type==tcons)        val= CDR(val);
517          switch(val->type){
518          case empty:
519            break;
520          case tcons:
521          printf(" ");          printf(" ");
522        else          break;
523          default:
524          printf(" . ");          /* Improper list */          printf(" . ");          /* Improper list */
525        stack_head= CDR(stack_head);          print_val(val, noquote);
526      }        }
527        } while(val->type == tcons);
528      printf(" ]");      printf(" ]");
529      break;      break;
530    }    }
# Line 528  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 547  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 564  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 1323  value *copy_val(environment *env, value Line 1332  value *copy_val(environment *env, value
1332      break;      break;
1333    case tcons:    case tcons:
1334    
1335      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(pair));
1336      assert(new_value->content.c!=NULL);      assert(new_value->content.c!=NULL);
1337    
1338      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
# Line 1716  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 2271  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    }
2356    
2357    extern void cons(environment *env)
2358    {
2359      value *val;
2360    
2361      if(env->head->type==empty || CDR(env->head)->type==empty) {
2362        printerr("Too Few Arguments");
2363        env->err= 1;
2364        return;
2365      }
2366    
2367      val=new_val(env);
2368      val->content.c= malloc(sizeof(pair));
2369      assert(val->content.c!=NULL);
2370      val->type=tcons;
2371    
2372      CAR(val)= CAR(CDR(env->head));
2373      CDR(val)= CAR(env->head);
2374    
2375      push_val(env, val);
2376    
2377      swap(env); if(env->err) return;
2378      toss(env); if(env->err) return;
2379      swap(env); if(env->err) return;
2380      toss(env); if(env->err) return;
2381    }
Legend:
Removed from v.1.111  
changed lines
  Added in v.1.115
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26