/[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.121 by masse, Wed Mar 27 14:45:17 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 123  value* new_val(environment *env) Line 123  value* new_val(environment *env)
123    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
124    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
125    
126      assert(nval != NULL);
127      assert(nitem != NULL);
128    
129    nval->content.ptr= NULL;    nval->content.ptr= NULL;
130    nval->type= integer;    nval->type= empty;
131    
132    nitem->item= nval;    nitem->item= nval;
133    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
# Line 165  inline void gc_maybe(environment *env) Line 168  inline void gc_maybe(environment *env)
168  extern void gc_init(environment *env)  extern void gc_init(environment *env)
169  {  {
170    stackitem *new_head= NULL, *titem;    stackitem *new_head= NULL, *titem;
   cons *iterator;  
171    symbol *tsymb;    symbol *tsymb;
172    int i;    int i;
173    
# Line 195  extern void gc_init(environment *env) Line 197  extern void gc_init(environment *env)
197    
198      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
199    
200        if(env->gc_ref->item->type==string) /* Remove content */        /* Remove content */
201          switch(env->gc_ref->item->type){
202          case string:
203          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
204            break;
205          case tcons:
206            free(env->gc_ref->item->content.c);
207            break;
208          case empty:
209          case integer:
210          case tfloat:
211          case func:
212          case symb:
213            /* Symbol strings are freed when walking the hash table */
214          }
215    
216        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
217        titem= env->gc_ref->next;        titem= env->gc_ref->next;
# Line 233  extern void gc_init(environment *env) Line 248  extern void gc_init(environment *env)
248      /* Keep values */          /* Keep values */    
249      env->gc_count += sizeof(value);      env->gc_count += sizeof(value);
250      if(env->gc_ref->item->type==string)      if(env->gc_ref->item->type==string)
251        env->gc_count += strlen(env->gc_ref->item->content.ptr);        env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
252            
253      titem= env->gc_ref->next;      titem= env->gc_ref->next;
254      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
# Line 285  void push_val(environment *env, value *v Line 300  void push_val(environment *env, value *v
300  {  {
301    value *new_value= new_val(env);    value *new_value= new_val(env);
302    
303    new_value->content.c= malloc(sizeof(cons));    new_value->content.c= malloc(sizeof(pair));
304    assert(new_value->content.c!=NULL);    assert(new_value->content.c!=NULL);
305      env->gc_count += sizeof(pair);
306    new_value->type= tcons;    new_value->type= tcons;
307    CAR(new_value)= val;    CAR(new_value)= val;
308    CDR(new_value)= env->head;    CDR(new_value)= env->head;
# Line 322  void push_cstring(environment *env, cons Line 338  void push_cstring(environment *env, cons
338    int length= strlen(in_string)+1;    int length= strlen(in_string)+1;
339    
340    new_value->content.ptr= malloc(length);    new_value->content.ptr= malloc(length);
341      assert(new_value != NULL);
342    env->gc_count += length;    env->gc_count += length;
343    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
344    new_value->type= string;    new_value->type= string;
# Line 336  char *mangle_str(const char *old_string) Line 353  char *mangle_str(const char *old_string)
353    char *new_string, *current;    char *new_string, *current;
354    
355    new_string= malloc((strlen(old_string)*2)+4);    new_string= malloc((strlen(old_string)*2)+4);
356      assert(new_string != NULL);
357    strcpy(new_string, "sx_");    /* Stack eXternal */    strcpy(new_string, "sx_");    /* Stack eXternal */
358    current= new_string+3;    current= new_string+3;
359    while(old_string[0] != '\0'){    while(old_string[0] != '\0'){
# Line 405  void push_sym(environment *env, const ch Line 423  void push_sym(environment *env, const ch
423    
424      /* Create a new symbol */      /* Create a new symbol */
425      (*new_symbol)= malloc(sizeof(symbol));      (*new_symbol)= malloc(sizeof(symbol));
426        assert((*new_symbol) != NULL);
427      (*new_symbol)->val= NULL;   /* undefined value */      (*new_symbol)->val= NULL;   /* undefined value */
428      (*new_symbol)->next= NULL;      (*new_symbol)->next= NULL;
429      (*new_symbol)->id= malloc(strlen(in_string)+1);      (*new_symbol)->id= malloc(strlen(in_string)+1);
430        assert((*new_symbol)->id != NULL);
431      strcpy((*new_symbol)->id, in_string);      strcpy((*new_symbol)->id, in_string);
432    
433      /* Intern the new symbol in the hash table */      /* Intern the new symbol in the hash table */
# Line 450  extern void nl() Line 470  extern void nl()
470  /* Gets the type of a value */  /* Gets the type of a value */
471  extern void type(environment *env)  extern void type(environment *env)
472  {  {
   int typenum;  
   
473    if(env->head->type==empty) {    if(env->head->type==empty) {
474      printerr("Too Few Arguments");      printerr("Too Few Arguments");
475      env->err= 1;      env->err= 1;
476      return;      return;
477    }    }
478    
479    typenum= CAR(env->head)->type;    switch(CAR(env->head)->type){
480    toss(env);    case empty:
481    switch(typenum){      push_sym(env, "empty");
482        break;
483    case integer:    case integer:
484      push_sym(env, "integer");      push_sym(env, "integer");
485      break;      break;
# Line 477  extern void type(environment *env) Line 496  extern void type(environment *env)
496      push_sym(env, "function");      push_sym(env, "function");
497      break;      break;
498    case tcons:    case tcons:
499      push_sym(env, "list");      push_sym(env, "pair");
500      break;      break;
501    }    }
502      swap(env);
503      if (env->err) return;
504      toss(env);
505  }      }    
506    
507  /* Prints the top element of the stack. */  /* Print a value */
508  void print_h(value *stack_head, int noquote)  void print_val(value *val, int noquote, stackitem *stack)
509  {  {
510    switch(CAR(stack_head)->type) {    stackitem *titem, *tstack;
511      int depth;
512    
513      switch(val->type) {
514      case empty:
515        printf("[]");
516        break;
517    case integer:    case integer:
518      printf("%d", CAR(stack_head)->content.i);      printf("%d", val->content.i);
519      break;      break;
520    case tfloat:    case tfloat:
521      printf("%f", CAR(stack_head)->content.f);      printf("%f", val->content.f);
522      break;      break;
523    case string:    case string:
524      if(noquote)      if(noquote)
525        printf("%s", (char*)CAR(stack_head)->content.ptr);        printf("%s", (char*)(val->content.ptr));
526      else      else
527        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);        printf("\"%s\"", (char*)(val->content.ptr));
528      break;      break;
529    case symb:    case symb:
530      printf("%s", CAR(stack_head)->content.sym->id);      printf("%s", val->content.sym->id);
531      break;      break;
532    case func:    case func:
533      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));      printf("#<function %p>", (funcp)(val->content.ptr));
534      break;      break;
535    case tcons:    case tcons:
     /* A list is just a stack, so make stack_head point to it */  
     stack_head= CAR(stack_head);  
536      printf("[ ");      printf("[ ");
537      while(CAR(stack_head)->type != empty) {      tstack= stack;
538        print_h(stack_head, noquote);      do {
539        if(CDR(stack_head)->type==tcons)        titem=malloc(sizeof(stackitem));
540          printf(" ");        assert(titem != NULL);
541        else        titem->item=val;
542          titem->next=tstack;
543          tstack=titem;             /* Put it on the stack */
544          /* Search a stack of values being printed to see if we are already
545             printing this value */
546          titem=tstack;
547          depth=0;
548          while(titem != NULL && titem->item != CAR(val)){
549            titem=titem->next;
550            depth++;
551          }
552          if(titem != NULL){        /* If we found it on the stack, */
553            printf("#%d#", depth);  /* print a depth reference */
554          } else {
555            print_val(CAR(val), noquote, tstack);
556          }
557          val= CDR(val);
558          switch(val->type){
559          case empty:
560            break;
561          case tcons:
562            /* Search a stack of values being printed to see if we are already
563               printing this value */
564            titem=tstack;
565            depth=0;
566            while(titem != NULL && titem->item != val){
567              titem=titem->next;
568              depth++;
569            }
570            if(titem != NULL){      /* If we found it on the stack, */
571              printf(" . #%d#", depth); /* print a depth reference */
572            } else {
573              printf(" ");
574            }
575            break;
576          default:
577          printf(" . ");          /* Improper list */          printf(" . ");          /* Improper list */
578        stack_head= CDR(stack_head);          print_val(val, noquote, tstack);
579          }
580        } while(val->type == tcons && titem == NULL);
581        titem=tstack;
582        while(titem != stack){
583          tstack=titem->next;
584          free(titem);
585          titem=tstack;
586      }      }
587      printf(" ]");      printf(" ]");
588      break;      break;
# Line 528  extern void print_(environment *env) Line 596  extern void print_(environment *env)
596      env->err= 1;      env->err= 1;
597      return;      return;
598    }    }
599    print_h(env->head, 0);    print_val(CAR(env->head), 0, NULL);
600    nl();    nl();
601  }  }
602    
# Line 547  extern void princ_(environment *env) Line 615  extern void princ_(environment *env)
615      env->err= 1;      env->err= 1;
616      return;      return;
617    }    }
618    print_h(env->head, 1);    print_val(CAR(env->head), 1, NULL);
619  }  }
620    
621  /* 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 632  void print_st(value *stack_head, long co
632    if(CDR(stack_head)->type != empty)    if(CDR(stack_head)->type != empty)
633      print_st(CDR(stack_head), counter+1);      print_st(CDR(stack_head), counter+1);
634    printf("%ld: ", counter);    printf("%ld: ", counter);
635    print_h(stack_head, 0);    print_val(CAR(stack_head), 0, NULL);
636    nl();    nl();
637  }  }
638    
# Line 711  extern void eval(environment *env) Line 779  extern void eval(environment *env)
779      unprotect(temp_val);      unprotect(temp_val);
780      return;      return;
781    
782    default:    case empty:
783      case integer:
784      case tfloat:
785      case string:
786      return;      return;
787    }    }
788  }  }
# Line 738  extern void rev(environment *env) Line 809  extern void rev(environment *env)
809    
810    old_head= CAR(env->head);    old_head= CAR(env->head);
811    new_head= new_val(env);    new_head= new_val(env);
   new_head->type= empty;  
812    while(old_head->type != empty) {    while(old_head->type != empty) {
813      item= old_head;      item= old_head;
814      old_head= CDR(old_head);      old_head= CDR(old_head);
# Line 754  extern void pack(environment *env) Line 824  extern void pack(environment *env)
824    value *iterator, *temp, *ending;    value *iterator, *temp, *ending;
825    
826    ending=new_val(env);    ending=new_val(env);
   ending->type=empty;  
827    
828    iterator= env->head;    iterator= env->head;
829    if(iterator->type == empty    if(iterator->type == empty
# Line 1100  extern void sx_2b(environment *env) Line 1169  extern void sx_2b(environment *env)
1169      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1170      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
1171      new_string= malloc(len);      new_string= malloc(len);
1172        assert(new_string != NULL);
1173      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1174      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1175      push_cstring(env, new_string);      push_cstring(env, new_string);
# Line 1315  value *copy_val(environment *env, value Line 1385  value *copy_val(environment *env, value
1385    case integer:    case integer:
1386    case func:    case func:
1387    case symb:    case symb:
1388      case empty:
1389      new_value->content= old_value->content;      new_value->content= old_value->content;
1390      break;      break;
1391    case string:    case string:
# Line 1323  value *copy_val(environment *env, value Line 1394  value *copy_val(environment *env, value
1394      break;      break;
1395    case tcons:    case tcons:
1396    
1397      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(pair));
1398      assert(new_value->content.c!=NULL);      assert(new_value->content.c!=NULL);
1399        env->gc_count += sizeof(pair);
1400    
1401      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1402      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
# Line 1598  extern void foreach(environment *env) Line 1670  extern void foreach(environment *env)
1670  extern void to(environment *env)  extern void to(environment *env)
1671  {  {
1672    int ending, start, i;    int ending, start, i;
1673    value *iterator, *temp;    value *iterator, *temp, *end;
1674    
1675      end= new_val(env);
1676    
1677    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1678      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 1633  extern void to(environment *env) Line 1707  extern void to(environment *env)
1707    if(iterator->type==empty    if(iterator->type==empty
1708       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
1709           && CAR(iterator)->content.sym->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1710      temp= NULL;      temp= end;
1711      toss(env);      toss(env);
1712    } else {    } else {
1713      /* Search for first delimiter */      /* Search for first delimiter */
1714      while(CDR(iterator)!=NULL      while(CDR(iterator)->type!=empty
1715            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
1716                || CAR(CDR(iterator))->content.sym->id[0]!='['))                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1717        iterator= CDR(iterator);        iterator= CDR(iterator);
# Line 1645  extern void to(environment *env) Line 1719  extern void to(environment *env)
1719      /* Extract list */      /* Extract list */
1720      temp= env->head;      temp= env->head;
1721      env->head= CDR(iterator);      env->head= CDR(iterator);
1722      CDR(iterator)= NULL;      CDR(iterator)= end;
1723    
1724      if(env->head!=NULL)      if(env->head->type!=empty)
1725        toss(env);        toss(env);
1726    }    }
1727    
# Line 1682  extern void sx_72656164(environment *env Line 1756  extern void sx_72656164(environment *env
1756    int count= -1;    int count= -1;
1757    float ftemp;    float ftemp;
1758    static int depth= 0;    static int depth= 0;
1759    char *match, *ctemp;    char *match;
1760    size_t inlength;    size_t inlength;
1761    
1762    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1697  extern void sx_72656164(environment *env Line 1771  extern void sx_72656164(environment *env
1771      }      }
1772            
1773      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1774        assert(env->in_string != NULL);
1775      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1776      strcpy(env->in_string, CAR(env->head)->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1777      toss(env); if(env->err) return;      toss(env); if(env->err) return;
# Line 1704  extern void sx_72656164(environment *env Line 1779  extern void sx_72656164(environment *env
1779        
1780    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1781    match= malloc(inlength);    match= malloc(inlength);
1782      assert(match != NULL);
1783    
1784    if(sscanf(env->in_string, blankform, &readlength) != EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1785       && readlength != -1) {       && readlength != -1) {
# Line 1716  extern void sx_72656164(environment *env Line 1792  extern void sx_72656164(environment *env
1792      } else {      } else {
1793        push_float(env, ftemp);        push_float(env, ftemp);
1794      }      }
1795      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1796                && readlength != -1) {
1797        push_cstring(env, "");
1798    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1799              && readlength != -1) {              && readlength != -1) {
1800      push_cstring(env, match);      push_cstring(env, match);
# Line 2271  extern void sx_646976(environment *env) Line 2350  extern void sx_646976(environment *env)
2350    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2351    env->err= 2;    env->err= 2;
2352  }  }
2353    
2354    extern void setcar(environment *env)
2355    {
2356      if(env->head->type==empty || CDR(env->head)->type==empty) {
2357        printerr("Too Few Arguments");
2358        env->err= 1;
2359        return;
2360      }
2361    
2362      if(CDR(env->head)->type!=tcons) {
2363        printerr("Bad Argument Type");
2364        env->err= 2;
2365        return;
2366      }
2367    
2368      CAR(CAR(CDR(env->head)))=CAR(env->head);
2369      toss(env);
2370    }
2371    
2372    extern void setcdr(environment *env)
2373    {
2374      if(env->head->type==empty || CDR(env->head)->type==empty) {
2375        printerr("Too Few Arguments");
2376        env->err= 1;
2377        return;
2378      }
2379    
2380      if(CDR(env->head)->type!=tcons) {
2381        printerr("Bad Argument Type");
2382        env->err= 2;
2383        return;
2384      }
2385    
2386      CDR(CAR(CDR(env->head)))=CAR(env->head);
2387      toss(env);
2388    }
2389    
2390    extern void car(environment *env)
2391    {
2392      if(env->head->type==empty) {
2393        printerr("Too Few Arguments");
2394        env->err= 1;
2395        return;
2396      }
2397    
2398      if(CAR(env->head)->type!=tcons) {
2399        printerr("Bad Argument Type");
2400        env->err= 2;
2401        return;
2402      }
2403    
2404      CAR(env->head)=CAR(CAR(env->head));
2405    }
2406    
2407    extern void cdr(environment *env)
2408    {
2409      if(env->head->type==empty) {
2410        printerr("Too Few Arguments");
2411        env->err= 1;
2412        return;
2413      }
2414    
2415      if(CAR(env->head)->type!=tcons) {
2416        printerr("Bad Argument Type");
2417        env->err= 2;
2418        return;
2419      }
2420    
2421      CAR(env->head)=CDR(CAR(env->head));
2422    }
2423    
2424    extern void cons(environment *env)
2425    {
2426      value *val;
2427    
2428      if(env->head->type==empty || CDR(env->head)->type==empty) {
2429        printerr("Too Few Arguments");
2430        env->err= 1;
2431        return;
2432      }
2433    
2434      val=new_val(env);
2435      val->content.c= malloc(sizeof(pair));
2436      assert(val->content.c!=NULL);
2437    
2438      env->gc_count += sizeof(pair);
2439      val->type=tcons;
2440    
2441      CAR(val)= CAR(CDR(env->head));
2442      CDR(val)= CAR(env->head);
2443    
2444      push_val(env, val);
2445    
2446      swap(env); if(env->err) return;
2447      toss(env); if(env->err) return;
2448      swap(env); if(env->err) return;
2449      toss(env); if(env->err) return;
2450    }
2451    
2452    /*  2: 3                        =>                */
2453    /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
2454    extern void assq(environment *env)
2455    {
2456      assocgen(env, eq);
2457    }
2458    
2459    
2460    /* General assoc function */
2461    void assocgen(environment *env, funcp eqfunc)
2462    {
2463      value *key, *item;
2464    
2465      /* Needs two values on the stack, the top one must be an association
2466         list */
2467      if(env->head->type==empty || CDR(env->head)->type==empty) {
2468        printerr("Too Few Arguments");
2469        env->err= 1;
2470        return;
2471      }
2472    
2473      if(CAR(env->head)->type!=tcons) {
2474        printerr("Bad Argument Type");
2475        env->err= 2;
2476        return;
2477      }
2478    
2479      key=CAR(CDR(env->head));
2480      item=CAR(env->head);
2481    
2482      while(item->type == tcons){
2483        if(CAR(item)->type != tcons){
2484          printerr("Bad Argument Type");
2485          env->err= 2;
2486          return;
2487        }
2488        push_val(env, key);
2489        push_val(env, CAR(CAR(item)));
2490        eqfunc(env); if(env->err) return;
2491    
2492        /* Check the result of 'eqfunc' */
2493        if(env->head->type==empty) {
2494          printerr("Too Few Arguments");
2495          env->err= 1;
2496        return;
2497        }
2498        if(CAR(env->head)->type!=integer) {
2499          printerr("Bad Argument Type");
2500          env->err= 2;
2501          return;
2502        }
2503    
2504        if(CAR(env->head)->content.i){
2505          toss(env); if(env->err) return;
2506          break;
2507        }
2508        toss(env); if(env->err) return;
2509    
2510        if(item->type!=tcons) {
2511          printerr("Bad Argument Type");
2512          env->err= 2;
2513          return;
2514        }
2515    
2516        item=CDR(item);
2517      }
2518    
2519      if(item->type == tcons){      /* A match was found */
2520        push_val(env, CAR(item));
2521      } else {
2522        push_int(env, 0);
2523      }
2524      swap(env); if(env->err) return;
2525      toss(env); if(env->err) return;
2526      swap(env); if(env->err) return;
2527      toss(env);
2528    }
Legend:
Removed from v.1.111  
changed lines
  Added in v.1.121
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26