/[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.117 by teddy, Wed Mar 20 05:29:29 2002 UTC
# Line 1  Line 1 
1    /* -*- coding: utf-8; -*- */
2  /*  /*
3      stack - an interactive interpreter for a stack-based language      stack - an interactive interpreter for a stack-based language
4      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn
# Line 20  Line 21 
21               Teddy Hogeborn <teddy@fukt.bth.se>               Teddy Hogeborn <teddy@fukt.bth.se>
22  */  */
23    
24  #define CAR(X) X->content.c->car  #define CAR(X) ((X)->content.c->car)
25  #define CDR(X) X->content.c->cdr  #define CDR(X) ((X)->content.c->cdr)
26    
27  /* printf, sscanf, fgets, fprintf, fopen, perror */  /* printf, sscanf, fgets, fprintf, fopen, perror */
28  #include <stdio.h>  #include <stdio.h>
# Line 61  void init_env(environment *env) Line 62  void init_env(environment *env)
62    env->gc_ref= NULL;    env->gc_ref= NULL;
63    
64    env->head= new_val(env);    env->head= new_val(env);
   env->head->type= empty;  
65    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
66      env->symbols[i]= NULL;      env->symbols[i]= NULL;
67    env->err= 0;    env->err= 0;
# Line 124  value* new_val(environment *env) Line 124  value* new_val(environment *env)
124    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
125    
126    nval->content.ptr= NULL;    nval->content.ptr= NULL;
127    nval->type= integer;    nval->type= empty;
128    
129    nitem->item= nval;    nitem->item= nval;
130    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
# 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;
   cons *iterator;  
168    symbol *tsymb;    symbol *tsymb;
169    int i;    int i;
170    
# Line 195  extern void gc_init(environment *env) Line 194  extern void gc_init(environment *env)
194    
195      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
196    
197        if(env->gc_ref->item->type==string) /* Remove content */        /* Remove content */
198          switch(env->gc_ref->item->type){
199          case string:
200          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
201            break;
202          case tcons:
203            free(env->gc_ref->item->content.c);
204            break;
205          case empty:
206          case integer:
207          case tfloat:
208          case func:
209          case symb:
210            /* Symbol strings are freed when walking the hash table */
211          }
212    
213        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
214        titem= env->gc_ref->next;        titem= env->gc_ref->next;
# Line 233  extern void gc_init(environment *env) Line 245  extern void gc_init(environment *env)
245      /* Keep values */          /* Keep values */    
246      env->gc_count += sizeof(value);      env->gc_count += sizeof(value);
247      if(env->gc_ref->item->type==string)      if(env->gc_ref->item->type==string)
248        env->gc_count += strlen(env->gc_ref->item->content.ptr);        env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
249            
250      titem= env->gc_ref->next;      titem= env->gc_ref->next;
251      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
# Line 285  void push_val(environment *env, value *v Line 297  void push_val(environment *env, value *v
297  {  {
298    value *new_value= new_val(env);    value *new_value= new_val(env);
299    
300    new_value->content.c= malloc(sizeof(cons));    new_value->content.c= malloc(sizeof(pair));
301    assert(new_value->content.c!=NULL);    assert(new_value->content.c!=NULL);
302      env->gc_count += sizeof(pair);
303    new_value->type= tcons;    new_value->type= tcons;
304    CAR(new_value)= val;    CAR(new_value)= val;
305    CDR(new_value)= env->head;    CDR(new_value)= env->head;
# Line 476  extern void type(environment *env) Line 489  extern void type(environment *env)
489      push_sym(env, "function");      push_sym(env, "function");
490      break;      break;
491    case tcons:    case tcons:
492      push_sym(env, "list");      push_sym(env, "pair");
493      break;      break;
494    }    }
495    swap(env);    swap(env);
# Line 484  extern void type(environment *env) Line 497  extern void type(environment *env)
497    toss(env);    toss(env);
498  }      }    
499    
500  /* Prints the top element of the stack. */  /* Print a value */
501  void print_h(value *stack_head, int noquote)  void print_val(value *val, int noquote, stackitem *stack)
502  {  {
503    switch(CAR(stack_head)->type) {    stackitem *titem, *tstack;
504      int depth;
505    
506      switch(val->type) {
507    case empty:    case empty:
508      printf("[]");      printf("[]");
509      break;      break;
510    case integer:    case integer:
511      printf("%d", CAR(stack_head)->content.i);      printf("%d", val->content.i);
512      break;      break;
513    case tfloat:    case tfloat:
514      printf("%f", CAR(stack_head)->content.f);      printf("%f", val->content.f);
515      break;      break;
516    case string:    case string:
517      if(noquote)      if(noquote)
518        printf("%s", (char*)(CAR(stack_head)->content.ptr));        printf("%s", (char*)(val->content.ptr));
519      else      else
520        printf("\"%s\"", (char*)(CAR(stack_head)->content.ptr));        printf("\"%s\"", (char*)(val->content.ptr));
521      break;      break;
522    case symb:    case symb:
523      printf("%s", CAR(stack_head)->content.sym->id);      printf("%s", val->content.sym->id);
524      break;      break;
525    case func:    case func:
526      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));      printf("#<function %p>", (funcp)(val->content.ptr));
527      break;      break;
528    case tcons:    case tcons:
     /* A list is just a stack, so make stack_head point to it */  
     stack_head= CAR(stack_head);  
529      printf("[ ");      printf("[ ");
530      while(stack_head->type != empty) {      tstack= stack;
531        print_h(stack_head, noquote);      do {
532        switch(CDR(stack_head)->type){        titem=malloc(sizeof(stackitem));
533          titem->item=val;
534          titem->next=tstack;
535          tstack=titem;             /* Put it on the stack */
536          /* Search a stack of values being printed to see if we are already
537             printing this value */
538          titem=tstack;
539          depth=0;
540          while(titem != NULL && titem->item != CAR(val)){
541            titem=titem->next;
542            depth++;
543          }
544          if(titem != NULL){        /* If we found it on the stack, */
545            printf("#%d#", depth);  /* print a depth reference */
546          } else {
547            print_val(CAR(val), noquote, tstack);
548          }
549          val= CDR(val);
550          switch(val->type){
551        case empty:        case empty:
552          break;          break;
553        case tcons:        case tcons:
554          printf(" ");          /* Search a stack of values being printed to see if we are already
555               printing this value */
556            titem=tstack;
557            depth=0;
558            while(titem != NULL && titem->item != val){
559              titem=titem->next;
560              depth++;
561            }
562            if(titem != NULL){      /* If we found it on the stack, */
563              printf(" . #%d#", depth); /* print a depth reference */
564            } else {
565              printf(" ");
566            }
567          break;          break;
568        default:        default:
569          printf(" . ");          /* Improper list */          printf(" . ");          /* Improper list */
570            print_val(val, noquote, tstack);
571        }        }
572        stack_head= CDR(stack_head);      } while(val->type == tcons && titem == NULL);
573        titem=tstack;
574        while(titem != stack){
575          tstack=titem->next;
576          free(titem);
577          titem=tstack;
578      }      }
579      printf(" ]");      printf(" ]");
580      break;      break;
# Line 538  extern void print_(environment *env) Line 588  extern void print_(environment *env)
588      env->err= 1;      env->err= 1;
589      return;      return;
590    }    }
591    print_h(env->head, 0);    print_val(CAR(env->head), 0, NULL);
592    nl();    nl();
593  }  }
594    
# Line 557  extern void princ_(environment *env) Line 607  extern void princ_(environment *env)
607      env->err= 1;      env->err= 1;
608      return;      return;
609    }    }
610    print_h(env->head, 1);    print_val(CAR(env->head), 1, NULL);
611  }  }
612    
613  /* 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 624  void print_st(value *stack_head, long co
624    if(CDR(stack_head)->type != empty)    if(CDR(stack_head)->type != empty)
625      print_st(CDR(stack_head), counter+1);      print_st(CDR(stack_head), counter+1);
626    printf("%ld: ", counter);    printf("%ld: ", counter);
627    print_h(stack_head, 0);    print_val(CAR(stack_head), 0, NULL);
628    nl();    nl();
629  }  }
630    
# Line 721  extern void eval(environment *env) Line 771  extern void eval(environment *env)
771      unprotect(temp_val);      unprotect(temp_val);
772      return;      return;
773    
774    default:    case empty:
775      case integer:
776      case tfloat:
777      case string:
778      return;      return;
779    }    }
780  }  }
# Line 748  extern void rev(environment *env) Line 801  extern void rev(environment *env)
801    
802    old_head= CAR(env->head);    old_head= CAR(env->head);
803    new_head= new_val(env);    new_head= new_val(env);
   new_head->type= empty;  
804    while(old_head->type != empty) {    while(old_head->type != empty) {
805      item= old_head;      item= old_head;
806      old_head= CDR(old_head);      old_head= CDR(old_head);
# Line 764  extern void pack(environment *env) Line 816  extern void pack(environment *env)
816    value *iterator, *temp, *ending;    value *iterator, *temp, *ending;
817    
818    ending=new_val(env);    ending=new_val(env);
   ending->type=empty;  
819    
820    iterator= env->head;    iterator= env->head;
821    if(iterator->type == empty    if(iterator->type == empty
# Line 1325  value *copy_val(environment *env, value Line 1376  value *copy_val(environment *env, value
1376    case integer:    case integer:
1377    case func:    case func:
1378    case symb:    case symb:
1379      case empty:
1380      new_value->content= old_value->content;      new_value->content= old_value->content;
1381      break;      break;
1382    case string:    case string:
# Line 1333  value *copy_val(environment *env, value Line 1385  value *copy_val(environment *env, value
1385      break;      break;
1386    case tcons:    case tcons:
1387    
1388      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(pair));
1389      assert(new_value->content.c!=NULL);      assert(new_value->content.c!=NULL);
1390        env->gc_count += sizeof(pair);
1391    
1392      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1393      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
# Line 1692  extern void sx_72656164(environment *env Line 1745  extern void sx_72656164(environment *env
1745    int count= -1;    int count= -1;
1746    float ftemp;    float ftemp;
1747    static int depth= 0;    static int depth= 0;
1748    char *match, *ctemp;    char *match;
1749    size_t inlength;    size_t inlength;
1750    
1751    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1726  extern void sx_72656164(environment *env Line 1779  extern void sx_72656164(environment *env
1779      } else {      } else {
1780        push_float(env, ftemp);        push_float(env, ftemp);
1781      }      }
1782      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1783                && readlength != -1) {
1784        push_cstring(env, "");
1785    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1786              && readlength != -1) {              && readlength != -1) {
1787      push_cstring(env, match);      push_cstring(env, match);
# Line 2281  extern void sx_646976(environment *env) Line 2337  extern void sx_646976(environment *env)
2337    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2338    env->err= 2;    env->err= 2;
2339  }  }
2340    
2341    extern void setcar(environment *env)
2342    {
2343      if(env->head->type==empty || CDR(env->head)->type==empty) {
2344        printerr("Too Few Arguments");
2345        env->err= 1;
2346        return;
2347      }
2348    
2349      if(CDR(env->head)->type!=tcons) {
2350        printerr("Bad Argument Type");
2351        env->err= 2;
2352        return;
2353      }
2354    
2355      CAR(CAR(CDR(env->head)))=CAR(env->head);
2356      toss(env);
2357    }
2358    
2359    extern void setcdr(environment *env)
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      if(CDR(env->head)->type!=tcons) {
2368        printerr("Bad Argument Type");
2369        env->err= 2;
2370        return;
2371      }
2372    
2373      CDR(CAR(CDR(env->head)))=CAR(env->head);
2374      toss(env);
2375    }
2376    
2377    extern void car(environment *env)
2378    {
2379      if(env->head->type==empty) {
2380        printerr("Too Few Arguments");
2381        env->err= 1;
2382        return;
2383      }
2384    
2385      if(CAR(env->head)->type!=tcons) {
2386        printerr("Bad Argument Type");
2387        env->err= 2;
2388        return;
2389      }
2390    
2391      CAR(env->head)=CAR(CAR(env->head));
2392    }
2393    
2394    extern void cdr(environment *env)
2395    {
2396      if(env->head->type==empty) {
2397        printerr("Too Few Arguments");
2398        env->err= 1;
2399        return;
2400      }
2401    
2402      if(CAR(env->head)->type!=tcons) {
2403        printerr("Bad Argument Type");
2404        env->err= 2;
2405        return;
2406      }
2407    
2408      CAR(env->head)=CDR(CAR(env->head));
2409    }
2410    
2411    extern void cons(environment *env)
2412    {
2413      value *val;
2414    
2415      if(env->head->type==empty || CDR(env->head)->type==empty) {
2416        printerr("Too Few Arguments");
2417        env->err= 1;
2418        return;
2419      }
2420    
2421      val=new_val(env);
2422      val->content.c= malloc(sizeof(pair));
2423      assert(val->content.c!=NULL);
2424    
2425      env->gc_count += sizeof(pair);
2426      val->type=tcons;
2427    
2428      CAR(val)= CAR(CDR(env->head));
2429      CDR(val)= CAR(env->head);
2430    
2431      push_val(env, val);
2432    
2433      swap(env); if(env->err) return;
2434      toss(env); if(env->err) return;
2435      swap(env); if(env->err) return;
2436      toss(env); if(env->err) return;
2437    }
Legend:
Removed from v.1.112  
changed lines
  Added in v.1.117
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26