/[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.116 by teddy, Sun Mar 17 12:49:27 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 165  inline void gc_maybe(environment *env) Line 166  inline void gc_maybe(environment *env)
166  extern void gc_init(environment *env)  extern void gc_init(environment *env)
167  {  {
168    stackitem *new_head= NULL, *titem;    stackitem *new_head= NULL, *titem;
   cons *iterator;  
169    symbol *tsymb;    symbol *tsymb;
170    int i;    int i;
171    
# Line 195  extern void gc_init(environment *env) Line 195  extern void gc_init(environment *env)
195    
196      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
197    
198        if(env->gc_ref->item->type==string) /* Remove content */        /* Remove content */
199          switch(env->gc_ref->item->type){
200          case string:
201          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
202            break;
203          case tcons:
204            free(env->gc_ref->item->content.c);
205            break;
206          case empty:
207          case integer:
208          case tfloat:
209          case func:
210          case symb:
211            /* Symbol strings are freed when walking the hash table */
212          }
213    
214        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
215        titem= env->gc_ref->next;        titem= env->gc_ref->next;
# Line 233  extern void gc_init(environment *env) Line 246  extern void gc_init(environment *env)
246      /* Keep values */          /* Keep values */    
247      env->gc_count += sizeof(value);      env->gc_count += sizeof(value);
248      if(env->gc_ref->item->type==string)      if(env->gc_ref->item->type==string)
249        env->gc_count += strlen(env->gc_ref->item->content.ptr);        env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
250            
251      titem= env->gc_ref->next;      titem= env->gc_ref->next;
252      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
# Line 285  void push_val(environment *env, value *v Line 298  void push_val(environment *env, value *v
298  {  {
299    value *new_value= new_val(env);    value *new_value= new_val(env);
300    
301    new_value->content.c= malloc(sizeof(cons));    new_value->content.c= malloc(sizeof(pair));
302    assert(new_value->content.c!=NULL);    assert(new_value->content.c!=NULL);
303      env->gc_count += sizeof(pair);
304    new_value->type= tcons;    new_value->type= tcons;
305    CAR(new_value)= val;    CAR(new_value)= val;
306    CDR(new_value)= env->head;    CDR(new_value)= env->head;
# Line 450  extern void nl() Line 464  extern void nl()
464  /* Gets the type of a value */  /* Gets the type of a value */
465  extern void type(environment *env)  extern void type(environment *env)
466  {  {
   int typenum;  
   
467    if(env->head->type==empty) {    if(env->head->type==empty) {
468      printerr("Too Few Arguments");      printerr("Too Few Arguments");
469      env->err= 1;      env->err= 1;
470      return;      return;
471    }    }
472    
473    typenum= CAR(env->head)->type;    switch(CAR(env->head)->type){
474    toss(env);    case empty:
475    switch(typenum){      push_sym(env, "empty");
476        break;
477    case integer:    case integer:
478      push_sym(env, "integer");      push_sym(env, "integer");
479      break;      break;
# Line 477  extern void type(environment *env) Line 490  extern void type(environment *env)
490      push_sym(env, "function");      push_sym(env, "function");
491      break;      break;
492    case tcons:    case tcons:
493      push_sym(env, "list");      push_sym(env, "pair");
494      break;      break;
495    }    }
496      swap(env);
497      if (env->err) return;
498      toss(env);
499  }      }    
500    
501  /* Prints the top element of the stack. */  /* Print a value */
502  void print_h(value *stack_head, int noquote)  void print_val(value *val, int noquote)
503  {  {
504    switch(CAR(stack_head)->type) {    switch(val->type) {
505      case empty:
506        printf("[]");
507        break;
508    case integer:    case integer:
509      printf("%d", CAR(stack_head)->content.i);      printf("%d", val->content.i);
510      break;      break;
511    case tfloat:    case tfloat:
512      printf("%f", CAR(stack_head)->content.f);      printf("%f", val->content.f);
513      break;      break;
514    case string:    case string:
515      if(noquote)      if(noquote)
516        printf("%s", (char*)CAR(stack_head)->content.ptr);        printf("%s", (char*)(val->content.ptr));
517      else      else
518        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);        printf("\"%s\"", (char*)(val->content.ptr));
519      break;      break;
520    case symb:    case symb:
521      printf("%s", CAR(stack_head)->content.sym->id);      printf("%s", val->content.sym->id);
522      break;      break;
523    case func:    case func:
524      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));      printf("#<function %p>", (funcp)(val->content.ptr));
525      break;      break;
526    case tcons:    case tcons:
     /* A list is just a stack, so make stack_head point to it */  
     stack_head= CAR(stack_head);  
527      printf("[ ");      printf("[ ");
528      while(CAR(stack_head)->type != empty) {      do {
529        print_h(stack_head, noquote);        print_val(CAR(val), noquote);
530        if(CDR(stack_head)->type==tcons)        val= CDR(val);
531          switch(val->type){
532          case empty:
533            break;
534          case tcons:
535          printf(" ");          printf(" ");
536        else          break;
537          default:
538          printf(" . ");          /* Improper list */          printf(" . ");          /* Improper list */
539        stack_head= CDR(stack_head);          print_val(val, noquote);
540      }        }
541        } while(val->type == tcons);
542      printf(" ]");      printf(" ]");
543      break;      break;
544    }    }
# Line 528  extern void print_(environment *env) Line 551  extern void print_(environment *env)
551      env->err= 1;      env->err= 1;
552      return;      return;
553    }    }
554    print_h(env->head, 0);    print_val(CAR(env->head), 0);
555    nl();    nl();
556  }  }
557    
# Line 547  extern void princ_(environment *env) Line 570  extern void princ_(environment *env)
570      env->err= 1;      env->err= 1;
571      return;      return;
572    }    }
573    print_h(env->head, 1);    print_val(CAR(env->head), 1);
574  }  }
575    
576  /* 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 587  void print_st(value *stack_head, long co
587    if(CDR(stack_head)->type != empty)    if(CDR(stack_head)->type != empty)
588      print_st(CDR(stack_head), counter+1);      print_st(CDR(stack_head), counter+1);
589    printf("%ld: ", counter);    printf("%ld: ", counter);
590    print_h(stack_head, 0);    print_val(CAR(stack_head), 0);
591    nl();    nl();
592  }  }
593    
# Line 711  extern void eval(environment *env) Line 734  extern void eval(environment *env)
734      unprotect(temp_val);      unprotect(temp_val);
735      return;      return;
736    
737    default:    case empty:
738      case integer:
739      case tfloat:
740      case string:
741      return;      return;
742    }    }
743  }  }
# Line 1315  value *copy_val(environment *env, value Line 1341  value *copy_val(environment *env, value
1341    case integer:    case integer:
1342    case func:    case func:
1343    case symb:    case symb:
1344      case empty:
1345      new_value->content= old_value->content;      new_value->content= old_value->content;
1346      break;      break;
1347    case string:    case string:
# Line 1323  value *copy_val(environment *env, value Line 1350  value *copy_val(environment *env, value
1350      break;      break;
1351    case tcons:    case tcons:
1352    
1353      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(pair));
1354      assert(new_value->content.c!=NULL);      assert(new_value->content.c!=NULL);
1355        env->gc_count += sizeof(pair);
1356    
1357      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1358      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
# Line 1682  extern void sx_72656164(environment *env Line 1710  extern void sx_72656164(environment *env
1710    int count= -1;    int count= -1;
1711    float ftemp;    float ftemp;
1712    static int depth= 0;    static int depth= 0;
1713    char *match, *ctemp;    char *match;
1714    size_t inlength;    size_t inlength;
1715    
1716    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1716  extern void sx_72656164(environment *env Line 1744  extern void sx_72656164(environment *env
1744      } else {      } else {
1745        push_float(env, ftemp);        push_float(env, ftemp);
1746      }      }
1747      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1748                && readlength != -1) {
1749        push_cstring(env, "");
1750    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1751              && readlength != -1) {              && readlength != -1) {
1752      push_cstring(env, match);      push_cstring(env, match);
# Line 2271  extern void sx_646976(environment *env) Line 2302  extern void sx_646976(environment *env)
2302    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2303    env->err= 2;    env->err= 2;
2304  }  }
2305    
2306    extern void setcar(environment *env)
2307    {
2308      if(env->head->type==empty || CDR(env->head)->type==empty) {
2309        printerr("Too Few Arguments");
2310        env->err= 1;
2311        return;
2312      }
2313    
2314      if(CDR(env->head)->type!=tcons) {
2315        printerr("Bad Argument Type");
2316        env->err= 2;
2317        return;
2318      }
2319    
2320      CAR(CAR(CDR(env->head)))=CAR(env->head);
2321      toss(env);
2322    }
2323    
2324    extern void setcdr(environment *env)
2325    {
2326      if(env->head->type==empty || CDR(env->head)->type==empty) {
2327        printerr("Too Few Arguments");
2328        env->err= 1;
2329        return;
2330      }
2331    
2332      if(CDR(env->head)->type!=tcons) {
2333        printerr("Bad Argument Type");
2334        env->err= 2;
2335        return;
2336      }
2337    
2338      CDR(CAR(CDR(env->head)))=CAR(env->head);
2339      toss(env);
2340    }
2341    
2342    extern void car(environment *env)
2343    {
2344      if(env->head->type==empty) {
2345        printerr("Too Few Arguments");
2346        env->err= 1;
2347        return;
2348      }
2349    
2350      if(CAR(env->head)->type!=tcons) {
2351        printerr("Bad Argument Type");
2352        env->err= 2;
2353        return;
2354      }
2355    
2356      CAR(env->head)=CAR(CAR(env->head));
2357    }
2358    
2359    extern void cdr(environment *env)
2360    {
2361      if(env->head->type==empty) {
2362        printerr("Too Few Arguments");
2363        env->err= 1;
2364        return;
2365      }
2366    
2367      if(CAR(env->head)->type!=tcons) {
2368        printerr("Bad Argument Type");
2369        env->err= 2;
2370        return;
2371      }
2372    
2373      CAR(env->head)=CDR(CAR(env->head));
2374    }
2375    
2376    extern void cons(environment *env)
2377    {
2378      value *val;
2379    
2380      if(env->head->type==empty || CDR(env->head)->type==empty) {
2381        printerr("Too Few Arguments");
2382        env->err= 1;
2383        return;
2384      }
2385    
2386      val=new_val(env);
2387      val->content.c= malloc(sizeof(pair));
2388      assert(val->content.c!=NULL);
2389    
2390      env->gc_count += sizeof(pair);
2391      val->type=tcons;
2392    
2393      CAR(val)= CAR(CDR(env->head));
2394      CDR(val)= CAR(env->head);
2395    
2396      push_val(env, val);
2397    
2398      swap(env); if(env->err) return;
2399      toss(env); if(env->err) return;
2400      swap(env); if(env->err) return;
2401      toss(env); if(env->err) return;
2402    }
Legend:
Removed from v.1.111  
changed lines
  Added in v.1.116
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26