/[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.109 by masse, Thu Mar 14 10:39:11 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 255  void push_val(environment *env, value *v Line 261  void push_val(environment *env, value *v
261    value *new_value= new_val(env);    value *new_value= new_val(env);
262    
263    new_value->content.c= malloc(sizeof(cons));    new_value->content.c= malloc(sizeof(cons));
264      assert(new_value->content.c!=NULL);
265    new_value->type= tcons;    new_value->type= tcons;
266    CAR(new_value)= val;    CAR(new_value)= val;
267    CDR(new_value)= env->head;    CDR(new_value)= env->head;
# Line 467  void print_h(value *stack_head, int noqu Line 474  void print_h(value *stack_head, int noqu
474        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);
475      break;      break;
476    case symb:    case symb:
477      printf("%s", ((symbol *)(CAR(stack_head)->content.ptr))->id);      printf("%s", CAR(stack_head)->content.sym->id);
478      break;      break;
479    case func:    case func:
480      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 601  extern void rcl(environment *env)
601      return;      return;
602    }    }
603    
604    val= ((symbol *)(CAR(env->head)->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
605    if(val == NULL){    if(val == NULL){
606      printerr("Unbound Variable");      printerr("Unbound Variable");
607      env->err= 3;      env->err= 3;
# Line 655  extern void eval(environment *env) Line 662  extern void eval(environment *env)
662        push_val(env, CAR(iterator));        push_val(env, CAR(iterator));
663                
664        if(CAR(env->head)->type==symb        if(CAR(env->head)->type==symb
665           && (((symbol*)(CAR(env->head)->content.ptr))->id[0]==';')) {           && CAR(env->head)->content.sym->id[0]==';') {
666          toss(env);          toss(env);
667          if(env->err) return;          if(env->err) return;
668                    
# Line 717  extern void pack(environment *env) Line 724  extern void pack(environment *env)
724    iterator= env->head;    iterator= env->head;
725    if(iterator==NULL    if(iterator==NULL
726       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
727       && ((symbol*)(CAR(iterator)->content.ptr))->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
728      temp= NULL;      temp= NULL;
729      toss(env);      toss(env);
730    } else {    } else {
731      /* Search for first delimiter */      /* Search for first delimiter */
732      while(CDR(iterator)!=NULL      while(CDR(iterator)!=NULL
733            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
734             || ((symbol*)(CAR(CDR(iterator))->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
735        iterator= CDR(iterator);        iterator= CDR(iterator);
736            
737      /* Extract list */      /* Extract list */
# Line 883  extern void quit(environment *env) Line 890  extern void quit(environment *env)
890    if(env->free_string!=NULL)    if(env->free_string!=NULL)
891      free(env->free_string);      free(env->free_string);
892        
893    #ifdef __linux__
894    muntrace();    muntrace();
895    #endif
896    
897    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
898  }  }
# Line 940  extern void forget(environment *env) Line 949  extern void forget(environment *env)
949      return;      return;
950    }    }
951    
952    sym_id= ((symbol*)(CAR(stack_head)->content.ptr))->id;    sym_id= CAR(stack_head)->content.sym->id;
953    toss(env);    toss(env);
954    
955    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 967  int main(int argc, char **argv)
967    
968    int c;                        /* getopt option character */    int c;                        /* getopt option character */
969    
970    #ifdef __linux__
971    mtrace();    mtrace();
972    #endif
973    
974    init_env(&myenv);    init_env(&myenv);
975    
# Line 1013  under certain conditions; type `copying; Line 1024  under certain conditions; type `copying;
1024        return EXIT_SUCCESS;      /* EOF */        return EXIT_SUCCESS;      /* EOF */
1025      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1026                && CAR(myenv.head)->type==symb                && CAR(myenv.head)->type==symb
1027                && ((symbol*)(CAR(myenv.head)->content.ptr))->id[0]                && CAR(myenv.head)->content.sym->id[0]
1028                ==';') {                ==';') {
1029        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1030        eval(&myenv);        eval(&myenv);
# Line 1256  value *copy_val(environment *env, value Line 1267  value *copy_val(environment *env, value
1267    
1268    protect(old_value);    protect(old_value);
1269    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
1270    new_value->type= old_value->type;    new_value->type= old_value->type;
1271    
1272    switch(old_value->type){    switch(old_value->type){
# Line 1271  value *copy_val(environment *env, value Line 1281  value *copy_val(environment *env, value
1281        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1282      break;      break;
1283    case tcons:    case tcons:
     new_value= NULL;  
1284    
1285      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(cons));
1286        assert(new_value->content.c!=NULL);
1287    
1288      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1289      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
1290      break;      break;
1291    }    }
1292    
1293    unprotect(old_value); unprotect(new_value);    unprotect(old_value);
1294    
1295    return new_value;    return new_value;
1296  }  }
# Line 1362  extern void ifelse(environment *env) Line 1373  extern void ifelse(environment *env)
1373    eval(env);    eval(env);
1374  }  }
1375    
1376    extern void sx_656c7365(environment *env)
1377    {
1378      if(env->head==NULL || CDR(env->head)==NULL
1379         || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL
1380         || CDR(CDR(CDR(CDR(env->head))))==NULL) {
1381        printerr("Too Few Arguments");
1382        env->err= 1;
1383        return;
1384      }
1385    
1386      if(CAR(CDR(env->head))->type!=symb
1387         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1388         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1389         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1390        printerr("Bad Argument Type");
1391        env->err= 2;
1392        return;
1393      }
1394    
1395      swap(env); toss(env); rot(env); toss(env);
1396      ifelse(env);
1397    }
1398    
1399    extern void then(environment *env)
1400    {
1401      if(env->head==NULL || CDR(env->head)==NULL
1402         || CDR(CDR(env->head))==NULL) {
1403        printerr("Too Few Arguments");
1404        env->err= 1;
1405        return;
1406      }
1407    
1408      if(CAR(CDR(env->head))->type!=symb
1409         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1410        printerr("Bad Argument Type");
1411        env->err= 2;
1412        return;
1413      }
1414    
1415      swap(env); toss(env);
1416      sx_6966(env);
1417    }
1418    
1419  /* "while" */  /* "while" */
1420  extern void sx_7768696c65(environment *env)  extern void sx_7768696c65(environment *env)
1421  {  {
# Line 1488  extern void foreach(environment *env) Line 1542  extern void foreach(environment *env)
1542      push_val(env, CAR(iterator));      push_val(env, CAR(iterator));
1543      push_val(env, loop);      push_val(env, loop);
1544      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1545      if (CDR(iterator)->type == tcons){      if (iterator->type == tcons){
1546        iterator= CDR(iterator);        iterator= CDR(iterator);
1547      } else {      } else {
1548        printerr("Bad Argument Type"); /* Improper list */        printerr("Bad Argument Type"); /* Improper list */
# Line 1537  extern void to(environment *env) Line 1591  extern void to(environment *env)
1591    
1592    if(iterator==NULL    if(iterator==NULL
1593       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
1594           && ((symbol*)(CAR(iterator)->content.ptr))->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1595      temp= NULL;      temp= NULL;
1596      toss(env);      toss(env);
1597    } else {    } else {
1598      /* Search for first delimiter */      /* Search for first delimiter */
1599      while(CDR(iterator)!=NULL      while(CDR(iterator)!=NULL
1600            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
1601                || ((symbol*)(CAR(CDR(iterator))->content.ptr))->id[0]                || CAR(CDR(iterator))->content.sym->id[0]!='['))
               !='['))  
1602        iterator= CDR(iterator);        iterator= CDR(iterator);
1603            
1604      /* Extract list */      /* Extract list */
# Line 1653  extern void sx_72656164(environment *env Line 1706  extern void sx_72656164(environment *env
1706      return sx_72656164(env);      return sx_72656164(env);
1707  }  }
1708    
1709    #ifdef __linux__
1710  extern void beep(environment *env)  extern void beep(environment *env)
1711  {  {
1712    int freq, dur, period, ticks;    int freq, dur, period, ticks;
# Line 1695  extern void beep(environment *env) Line 1749  extern void beep(environment *env)
1749      abort();      abort();
1750    }    }
1751  }  }
1752    #endif /* __linux__ */
1753    
1754  /* "wait" */  /* "wait" */
1755  extern void sx_77616974(environment *env)  extern void sx_77616974(environment *env)
Legend:
Removed from v.1.104  
changed lines
  Added in v.1.109
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26