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

Diff of /stack/stack.c

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

revision 1.104 by masse, Tue Mar 12 14:06:05 2002 UTC revision 1.110 by teddy, Sat Mar 16 09:12:39 2002 UTC
# Line 37  Line 37 
37  #include <unistd.h>  #include <unistd.h>
38  /* EX_NOINPUT, EX_USAGE */  /* EX_NOINPUT, EX_USAGE */
39  #include <sysexits.h>  #include <sysexits.h>
40    /* assert */
41    #include <assert.h>
42    
43    #ifdef __linux__
44  /* mtrace, muntrace */  /* mtrace, muntrace */
45  #include <mcheck.h>  #include <mcheck.h>
46  /* ioctl */  /* ioctl */
47  #include <sys/ioctl.h>  #include <sys/ioctl.h>
48  /* KDMKTONE */  /* KDMKTONE */
49  #include <linux/kd.h>  #include <linux/kd.h>
50    #endif /* __linux__ */
51    
52  #include "stack.h"  #include "stack.h"
53    
# Line 118  value* new_val(environment *env) Line 123  value* new_val(environment *env)
123    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
124    
125    nval->content.ptr= NULL;    nval->content.ptr= NULL;
126      nval->type= integer;
127    
128    nitem->item= nval;    nitem->item= nval;
129    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
# Line 182  extern void gc_init(environment *env) Line 188  extern void gc_init(environment *env)
188    if(env->interactive)    if(env->interactive)
189      printf(".");      printf(".");
190    
   
191    env->gc_count= 0;    env->gc_count= 0;
192    
193    while(env->gc_ref!=NULL) {    /* Sweep unused values */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
# Line 197  extern void gc_init(environment *env) Line 202  extern void gc_init(environment *env)
202        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
203        env->gc_ref= titem;        env->gc_ref= titem;
204        continue;        continue;
205      }      }
206    #ifdef DEBUG
207        printf("Kept value (%p)", env->gc_ref->item);
208        if(env->gc_ref->item->gc.flag.mark)
209          printf(" (marked)");
210        if(env->gc_ref->item->gc.flag.protect)
211          printf(" (protected)");
212        switch(env->gc_ref->item->type){
213        case integer:
214          printf(" integer: %d", env->gc_ref->item->content.i);
215          break;
216        case func:
217          printf(" func: %p", env->gc_ref->item->content.ptr);
218          break;
219        case symb:
220          printf(" symb: %s", env->gc_ref->item->content.sym->id);
221          break;
222        case tcons:
223          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
224                 env->gc_ref->item->content.c->cdr);
225          break;
226        default:
227          printf(" <unknown %d>", (env->gc_ref->item->type));
228        }
229        printf("\n");
230    #endif /* DEBUG */
231    
232      /* Keep values */          /* Keep values */    
233      env->gc_count += sizeof(value);      env->gc_count += sizeof(value);
# Line 217  extern void gc_init(environment *env) Line 247  extern void gc_init(environment *env)
247    env->gc_ref= new_head;    env->gc_ref= new_head;
248    
249    if(env->interactive)    if(env->interactive)
250      printf("done\n");      printf("done (%d bytes still allocated)\n", env->gc_count);
251    
252  }  }
253    
# Line 255  void push_val(environment *env, value *v Line 285  void push_val(environment *env, value *v
285    value *new_value= new_val(env);    value *new_value= new_val(env);
286    
287    new_value->content.c= malloc(sizeof(cons));    new_value->content.c= malloc(sizeof(cons));
288      assert(new_value->content.c!=NULL);
289    new_value->type= tcons;    new_value->type= tcons;
290    CAR(new_value)= val;    CAR(new_value)= val;
291    CDR(new_value)= env->head;    CDR(new_value)= env->head;
# Line 467  void print_h(value *stack_head, int noqu Line 498  void print_h(value *stack_head, int noqu
498        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);
499      break;      break;
500    case symb:    case symb:
501      printf("%s", ((symbol *)(CAR(stack_head)->content.ptr))->id);      printf("%s", CAR(stack_head)->content.sym->id);
502      break;      break;
503    case func:    case func:
504      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));
# Line 594  extern void rcl(environment *env) Line 625  extern void rcl(environment *env)
625      return;      return;
626    }    }
627    
628    val= ((symbol *)(CAR(env->head)->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
629    if(val == NULL){    if(val == NULL){
630      printerr("Unbound Variable");      printerr("Unbound Variable");
631      env->err= 3;      env->err= 3;
632      return;      return;
633    }    }
634    protect(val);    push_val(env, val);           /* Return the symbol's bound value */
635    toss(env);            /* toss the symbol */    swap(env);
636      if(env->err) return;
637      toss(env);                    /* toss the symbol */
638    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(val);  
639  }  }
640    
641  /* If the top element is a symbol, determine if it's bound to a  /* If the top element is a symbol, determine if it's bound to a
# Line 655  extern void eval(environment *env) Line 686  extern void eval(environment *env)
686        push_val(env, CAR(iterator));        push_val(env, CAR(iterator));
687                
688        if(CAR(env->head)->type==symb        if(CAR(env->head)->type==symb
689           && (((symbol*)(CAR(env->head)->content.ptr))->id[0]==';')) {           && CAR(env->head)->content.sym->id[0]==';') {
690          toss(env);          toss(env);
691          if(env->err) return;          if(env->err) return;
692                    
# Line 665  extern void eval(environment *env) Line 696  extern void eval(environment *env)
696          eval(env);          eval(env);
697          if(env->err) return;          if(env->err) return;
698        }        }
699        if (CDR(iterator)->type == tcons)        if (CDR(iterator)==NULL || CDR(iterator)->type == tcons)
700          iterator= CDR(iterator);          iterator= CDR(iterator);
701        else {        else {
702          printerr("Bad Argument Type"); /* Improper list */          printerr("Bad Argument Type"); /* Improper list */
# Line 717  extern void pack(environment *env) Line 748  extern void pack(environment *env)
748    iterator= env->head;    iterator= env->head;
749    if(iterator==NULL    if(iterator==NULL
750       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
751       && ((symbol*)(CAR(iterator)->content.ptr))->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
752      temp= NULL;      temp= NULL;
753      toss(env);      toss(env);
754    } else {    } else {
755      /* Search for first delimiter */      /* Search for first delimiter */
756      while(CDR(iterator)!=NULL      while(CDR(iterator)!=NULL
757            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
758             || ((symbol*)(CAR(CDR(iterator))->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
759        iterator= CDR(iterator);        iterator= CDR(iterator);
760            
761      /* Extract list */      /* Extract list */
# Line 880  extern void quit(environment *env) Line 911  extern void quit(environment *env)
911    env->gc_limit= 0;    env->gc_limit= 0;
912    gc_maybe(env);    gc_maybe(env);
913    
914      words(env);
915    
916    if(env->free_string!=NULL)    if(env->free_string!=NULL)
917      free(env->free_string);      free(env->free_string);
918        
919    #ifdef __linux__
920    muntrace();    muntrace();
921    #endif
922    
923    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
924  }  }
# Line 904  extern void words(environment *env) Line 939  extern void words(environment *env)
939    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
940      temp= env->symbols[i];      temp= env->symbols[i];
941      while(temp!=NULL) {      while(temp!=NULL) {
942    #ifdef DEBUG
943          if (temp->val != NULL && temp->val->gc.flag.protect)
944            printf("(protected) ");
945    #endif /* DEBUG */
946        printf("%s\n", temp->id);        printf("%s\n", temp->id);
947        temp= temp->next;        temp= temp->next;
948      }      }
# Line 940  extern void forget(environment *env) Line 979  extern void forget(environment *env)
979      return;      return;
980    }    }
981    
982    sym_id= ((symbol*)(CAR(stack_head)->content.ptr))->id;    sym_id= CAR(stack_head)->content.sym->id;
983    toss(env);    toss(env);
984    
985    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
# Line 958  int main(int argc, char **argv) Line 997  int main(int argc, char **argv)
997    
998    int c;                        /* getopt option character */    int c;                        /* getopt option character */
999    
1000    #ifdef __linux__
1001    mtrace();    mtrace();
1002    #endif
1003    
1004    init_env(&myenv);    init_env(&myenv);
1005    
# Line 972  int main(int argc, char **argv) Line 1013  int main(int argc, char **argv)
1013          break;          break;
1014        case '?':        case '?':
1015          fprintf (stderr,          fprintf (stderr,
1016                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1017                   optopt);                   optopt);
1018          return EX_USAGE;          return EX_USAGE;
1019        default:        default:
# Line 991  int main(int argc, char **argv) Line 1032  int main(int argc, char **argv)
1032    if(myenv.interactive) {    if(myenv.interactive) {
1033      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1034  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1035  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1036  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1037  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1038    }    }
1039    
1040    while(1) {    while(1) {
# Line 1008  under certain conditions; type `copying; Line 1049  under certain conditions; type `copying;
1049        }        }
1050        myenv.err=0;        myenv.err=0;
1051      }      }
1052      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1053      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1054        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1055          quit(&myenv);
1056      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1057                && CAR(myenv.head)->type==symb                && CAR(myenv.head)->type==symb
1058                && ((symbol*)(CAR(myenv.head)->content.ptr))->id[0]                && CAR(myenv.head)->content.sym->id[0]
1059                ==';') {                ==';') {
1060        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1061        eval(&myenv);        eval(&myenv);
# Line 1256  value *copy_val(environment *env, value Line 1298  value *copy_val(environment *env, value
1298    
1299    protect(old_value);    protect(old_value);
1300    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
1301    new_value->type= old_value->type;    new_value->type= old_value->type;
1302    
1303    switch(old_value->type){    switch(old_value->type){
# Line 1271  value *copy_val(environment *env, value Line 1312  value *copy_val(environment *env, value
1312        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1313      break;      break;
1314    case tcons:    case tcons:
     new_value= NULL;  
1315    
1316      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(cons));
1317        assert(new_value->content.c!=NULL);
1318    
1319      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1320      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
1321      break;      break;
1322    }    }
1323    
1324    unprotect(old_value); unprotect(new_value);    unprotect(old_value);
1325    
1326    return new_value;    return new_value;
1327  }  }
# Line 1362  extern void ifelse(environment *env) Line 1404  extern void ifelse(environment *env)
1404    eval(env);    eval(env);
1405  }  }
1406    
1407    extern void sx_656c7365(environment *env)
1408    {
1409      if(env->head==NULL || CDR(env->head)==NULL
1410         || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL
1411         || CDR(CDR(CDR(CDR(env->head))))==NULL) {
1412        printerr("Too Few Arguments");
1413        env->err= 1;
1414        return;
1415      }
1416    
1417      if(CAR(CDR(env->head))->type!=symb
1418         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1419         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1420         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1421        printerr("Bad Argument Type");
1422        env->err= 2;
1423        return;
1424      }
1425    
1426      swap(env); toss(env); rot(env); toss(env);
1427      ifelse(env);
1428    }
1429    
1430    extern void then(environment *env)
1431    {
1432      if(env->head==NULL || CDR(env->head)==NULL
1433         || CDR(CDR(env->head))==NULL) {
1434        printerr("Too Few Arguments");
1435        env->err= 1;
1436        return;
1437      }
1438    
1439      if(CAR(CDR(env->head))->type!=symb
1440         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1441        printerr("Bad Argument Type");
1442        env->err= 2;
1443        return;
1444      }
1445    
1446      swap(env); toss(env);
1447      sx_6966(env);
1448    }
1449    
1450  /* "while" */  /* "while" */
1451  extern void sx_7768696c65(environment *env)  extern void sx_7768696c65(environment *env)
1452  {  {
# Line 1488  extern void foreach(environment *env) Line 1573  extern void foreach(environment *env)
1573      push_val(env, CAR(iterator));      push_val(env, CAR(iterator));
1574      push_val(env, loop);      push_val(env, loop);
1575      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1576      if (CDR(iterator)->type == tcons){      if (iterator->type == tcons){
1577        iterator= CDR(iterator);        iterator= CDR(iterator);
1578      } else {      } else {
1579        printerr("Bad Argument Type"); /* Improper list */        printerr("Bad Argument Type"); /* Improper list */
# Line 1537  extern void to(environment *env) Line 1622  extern void to(environment *env)
1622    
1623    if(iterator==NULL    if(iterator==NULL
1624       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
1625           && ((symbol*)(CAR(iterator)->content.ptr))->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1626      temp= NULL;      temp= NULL;
1627      toss(env);      toss(env);
1628    } else {    } else {
1629      /* Search for first delimiter */      /* Search for first delimiter */
1630      while(CDR(iterator)!=NULL      while(CDR(iterator)!=NULL
1631            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
1632                || ((symbol*)(CAR(CDR(iterator))->content.ptr))->id[0]                || CAR(CDR(iterator))->content.sym->id[0]!='['))
               !='['))  
1633        iterator= CDR(iterator);        iterator= CDR(iterator);
1634            
1635      /* Extract list */      /* Extract list */
# Line 1653  extern void sx_72656164(environment *env Line 1737  extern void sx_72656164(environment *env
1737      return sx_72656164(env);      return sx_72656164(env);
1738  }  }
1739    
1740    #ifdef __linux__
1741  extern void beep(environment *env)  extern void beep(environment *env)
1742  {  {
1743    int freq, dur, period, ticks;    int freq, dur, period, ticks;
# Line 1695  extern void beep(environment *env) Line 1780  extern void beep(environment *env)
1780      abort();      abort();
1781    }    }
1782  }  }
1783    #endif /* __linux__ */
1784    
1785  /* "wait" */  /* "wait" */
1786  extern void sx_77616974(environment *env)  extern void sx_77616974(environment *env)
Legend:
Removed from v.1.104  
changed lines
  Added in v.1.110
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26