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

Diff of /stack/stack.c

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

revision 1.89 by masse, Sun Feb 17 04:03:57 2002 UTC revision 1.90 by masse, Thu Mar 7 01:21:07 2002 UTC
# Line 24  void init_env(environment *env) Line 24  void init_env(environment *env)
24    
25    env->gc_limit= 20;    env->gc_limit= 20;
26    env->gc_count= 0;    env->gc_count= 0;
27      env->gc_ref= NULL;
28      env->gc_protect= NULL;
29    
30    env->head= NULL;    env->head= NULL;
31    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
# Line 46  extern void toss(environment *env) Line 48  extern void toss(environment *env)
48    
49    if((env->head)==NULL) {    if((env->head)==NULL) {
50      printerr("Too Few Arguments");      printerr("Too Few Arguments");
51      env->err=1;      env->err= 1;
52      return;      return;
53    }    }
54        
55    env->head= env->head->next;   /* Remove the top stack item */    env->head= env->head->next;   /* Remove the top stack item */
56    free(temp);                   /* Free the old top stack item */    free(temp);                   /* Free the old top stack item */
57    
58      gc_init(env);
59  }  }
60    
61  /* Returns a pointer to a pointer to an element in the hash table. */  /* Returns a pointer to a pointer to an element in the hash table. */
# Line 88  value* new_val(environment *env) { Line 92  value* new_val(environment *env) {
92    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
93    
94    nval->content.ptr= NULL;    nval->content.ptr= NULL;
95      protect(env, nval);
96    
97      gc_init(env);
98    
99    nitem->item= nval;    nitem->item= nval;
100    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
101    env->gc_ref= nitem;    env->gc_ref= nitem;
102    
103    env->gc_count++;    env->gc_count++;
104      unprotect(env);
105    
106    return nval;    return nval;
107  }  }
# Line 130  extern void gc_init(environment *env) { Line 138  extern void gc_init(environment *env) {
138    }    }
139    
140    /* Mark */    /* Mark */
141      iterator= env->gc_protect;
142      while(iterator!=NULL) {
143        gc_mark(iterator->item);
144        iterator= iterator->next;
145      }
146    
147    iterator= env->head;    iterator= env->head;
148    while(iterator!=NULL) {    while(iterator!=NULL) {
149      gc_mark(iterator->item);      gc_mark(iterator->item);
# Line 148  extern void gc_init(environment *env) { Line 162  extern void gc_init(environment *env) {
162    
163    /* Sweep */    /* Sweep */
164    while(env->gc_ref!=NULL) {    while(env->gc_ref!=NULL) {
165    
166      if(env->gc_ref->item->gc_garb) {      if(env->gc_ref->item->gc_garb) {
167        switch(env->gc_ref->item->type) {        switch(env->gc_ref->item->type) {
168        case string:        case string:
# Line 182  extern void gc_init(environment *env) { Line 197  extern void gc_init(environment *env) {
197    env->gc_ref= new_head;    env->gc_ref= new_head;
198  }  }
199    
200    void protect(environment *env, value *val)
201    {
202      stackitem *new_item= malloc(sizeof(stackitem));
203      new_item->item= val;
204      new_item->next= env->gc_protect;
205      env->gc_protect= new_item;
206    }
207    
208    void unprotect(environment *env)
209    {
210      stackitem *temp= env->gc_protect;
211      env->gc_protect= env->gc_protect->next;
212      free(temp);
213    }
214    
215  /* Push a value onto the stack */  /* Push a value onto the stack */
216  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
217  {  {
# Line 216  void push_cstring(environment *env, cons Line 246  void push_cstring(environment *env, cons
246    
247  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
248  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string){
249    char validchars[]    char validchars[]= "0123456789abcdef";
     ="0123456789abcdef";  
250    char *new_string, *current;    char *new_string, *current;
251    
252    new_string=malloc((strlen(old_string)*2)+4);    new_string= malloc((strlen(old_string)*2)+4);
253    strcpy(new_string, "sx_");    /* Stack eXternal */    strcpy(new_string, "sx_");    /* Stack eXternal */
254    current=new_string+3;    current= new_string+3;
255    while(old_string[0] != '\0'){    while(old_string[0] != '\0'){
256      current[0]=validchars[(unsigned char)(old_string[0])/16];      current[0]= validchars[(unsigned char)(old_string[0])/16];
257      current[1]=validchars[(unsigned char)(old_string[0])%16];      current[1]= validchars[(unsigned char)(old_string[0])%16];
258      current+=2;      current+= 2;
259      old_string++;      old_string++;
260    }    }
261    current[0]='\0';    current[0]= '\0';
262    
263    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
264  }  }
# Line 239  extern void mangle(environment *env){ Line 268  extern void mangle(environment *env){
268    
269    if((env->head)==NULL) {    if((env->head)==NULL) {
270      printerr("Too Few Arguments");      printerr("Too Few Arguments");
271      env->err=1;      env->err= 1;
272      return;      return;
273    }    }
274    
275    if(env->head->item->type!=string) {    if(env->head->item->type!=string) {
276      printerr("Bad Argument Type");      printerr("Bad Argument Type");
277      env->err=2;      env->err= 2;
278      return;      return;
279    }    }
280    
# Line 298  void push_sym(environment *env, const ch Line 327  void push_sym(environment *env, const ch
327      if(handle==NULL)            /* If no handle */      if(handle==NULL)            /* If no handle */
328        handle= dlopen(NULL, RTLD_LAZY);        handle= dlopen(NULL, RTLD_LAZY);
329    
330      mangled=mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
331      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
332      free(mangled);      free(mangled);
333      dlerr=dlerror();      dlerr= dlerror();
334      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
335        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
336        dlerr=dlerror();        dlerr= dlerror();
337      }      }
338      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
339        new_fvalue= new_val(env); /* Create a new value */        new_fvalue= new_val(env); /* Create a new value */
340        new_fvalue->type=func;    /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
341        new_fvalue->content.ptr=funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
342        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
343                                           function value */                                           function value */
344      }      }
# Line 497  extern void rcl(environment *env) Line 526  extern void rcl(environment *env)
526      env->err=3;      env->err=3;
527      return;      return;
528    }    }
529      protect(env, val);
530    toss(env);            /* toss the symbol */    toss(env);            /* toss the symbol */
531    if(env->err) return;    if(env->err) return;
532    push_val(env, val); /* Return its bound value */    push_val(env, val); /* Return its bound value */
533      unprotect(env);
534  }  }
535    
536  /* 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 539  extern void eval(environment *env) Line 570  extern void eval(environment *env)
570      /* If it's a list */      /* If it's a list */
571    case list:    case list:
572      temp_val= env->head->item;      temp_val= env->head->item;
573        protect(env, temp_val);
574      toss(env);      toss(env);
575      if(env->err) return;      if(env->err) return;
576      iterator= (stackitem*)temp_val->content.ptr;      iterator= (stackitem*)temp_val->content.ptr;
577        unprotect(env);
578        
579      while(iterator!=NULL) {      while(iterator!=NULL) {
580        push_val(env, iterator->item);        push_val(env, iterator->item);
581          
582        if(env->head->item->type==symb        if(env->head->item->type==symb
583          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {
584          toss(env);          toss(env);
585          if(env->err) return;          if(env->err) return;
586            
587          if(iterator->next == NULL){          if(iterator->next == NULL){
588            goto eval_start;            goto eval_start;
589          }          }
# Line 569  extern void rev(environment *env){ Line 605  extern void rev(environment *env){
605    
606    if((env->head)==NULL) {    if((env->head)==NULL) {
607      printerr("Too Few Arguments");      printerr("Too Few Arguments");
608      env->err=1;      env->err= 1;
609      return;      return;
610    }    }
611    
612    if(env->head->item->type!=list) {    if(env->head->item->type!=list) {
613      printerr("Bad Argument Type");      printerr("Bad Argument Type");
614      env->err=2;      env->err= 2;
615      return;      return;
616    }    }
617    
618    old_head=(stackitem *)(env->head->item->content.ptr);    old_head= (stackitem *)(env->head->item->content.ptr);
619    new_head=NULL;    new_head= NULL;
620    while(old_head != NULL){    while(old_head != NULL){
621      item=old_head;      item= old_head;
622      old_head=old_head->next;      old_head= old_head->next;
623      item->next=new_head;      item->next= new_head;
624      new_head=item;      new_head= item;
625    }    }
626    env->head->item->content.ptr=new_head;    env->head->item->content.ptr= new_head;
627  }  }
628    
629  /* Make a list. */  /* Make a list. */
# Line 636  extern void expand(environment *env) Line 672  extern void expand(environment *env)
672    /* Is top element a list? */    /* Is top element a list? */
673    if(env->head==NULL) {    if(env->head==NULL) {
674      printerr("Too Few Arguments");      printerr("Too Few Arguments");
675      env->err=1;      env->err= 1;
676      return;      return;
677    }    }
678    if(env->head->item->type!=list) {    if(env->head->item->type!=list) {
679      printerr("Bad Argument Type");      printerr("Bad Argument Type");
680      env->err=2;      env->err= 2;
681      return;      return;
682    }    }
683    
# Line 673  extern void eq(environment *env) Line 709  extern void eq(environment *env)
709    
710    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
711      printerr("Too Few Arguments");      printerr("Too Few Arguments");
712      env->err=1;      env->err= 1;
713      return;      return;
714    }    }
715    
# Line 693  extern void not(environment *env) Line 729  extern void not(environment *env)
729    
730    if((env->head)==NULL) {    if((env->head)==NULL) {
731      printerr("Too Few Arguments");      printerr("Too Few Arguments");
732      env->err=1;      env->err= 1;
733      return;      return;
734    }    }
735    
736    if(env->head->item->type!=integer) {    if(env->head->item->type!=integer) {
737      printerr("Bad Argument Type");      printerr("Bad Argument Type");
738      env->err=2;      env->err= 2;
739      return;      return;
740    }    }
741    
# Line 724  extern void def(environment *env) Line 760  extern void def(environment *env)
760    /* Needs two values on the stack, the top one must be a symbol */    /* Needs two values on the stack, the top one must be a symbol */
761    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->next==NULL) {
762      printerr("Too Few Arguments");      printerr("Too Few Arguments");
763      env->err=1;      env->err= 1;
764      return;      return;
765    }    }
766    
767    if(env->head->item->type!=symb) {    if(env->head->item->type!=symb) {
768      printerr("Bad Argument Type");      printerr("Bad Argument Type");
769      env->err=2;      env->err= 2;
770      return;      return;
771    }    }
772    
773    /* long names are a pain */    /* long names are a pain */
774    sym=env->head->item->content.ptr;    sym= env->head->item->content.ptr;
   
   /* if the symbol was bound to something else, throw it away */  
775    
776    /* Bind the symbol to the value */    /* Bind the symbol to the value */
777    sym->val= env->head->next->item;    sym->val= env->head->next->item;
# Line 760  extern void quit(environment *env) Line 794  extern void quit(environment *env)
794      env->symbols[i]= NULL;      env->symbols[i]= NULL;
795    }    }
796    
797      env->gc_limit= 0;
798    gc_init(env);    gc_init(env);
799    
800    if(env->free_string!=NULL)    if(env->free_string!=NULL)
# Line 904  extern void sx_2b(environment *env) { Line 939  extern void sx_2b(environment *env) {
939    
940    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
941      printerr("Too Few Arguments");      printerr("Too Few Arguments");
942      env->err=1;      env->err= 1;
943      return;      return;
944    }    }
945    
# Line 912  extern void sx_2b(environment *env) { Line 947  extern void sx_2b(environment *env) {
947       && env->head->next->item->type==string) {       && env->head->next->item->type==string) {
948      a_val= env->head->item;      a_val= env->head->item;
949      b_val= env->head->next->item;      b_val= env->head->next->item;
950        protect(env, a_val); protect(env, b_val);
951      toss(env); if(env->err) return;      toss(env); if(env->err) return;
952      toss(env); if(env->err) return;      toss(env); if(env->err) return;
953      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
# Line 919  extern void sx_2b(environment *env) { Line 955  extern void sx_2b(environment *env) {
955      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
956      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
957      push_cstring(env, new_string);      push_cstring(env, new_string);
958        unprotect(env); unprotect(env);
959      free(new_string);      free(new_string);
960      return;      return;
961    }    }
# Line 929  extern void sx_2b(environment *env) { Line 966  extern void sx_2b(environment *env) {
966      env->err=2;      env->err=2;
967      return;      return;
968    }    }
969    a=env->head->item->content.val;    a= env->head->item->content.val;
970    toss(env); if(env->err) return;    toss(env); if(env->err) return;
971        
972    b=env->head->item->content.val;    b= env->head->item->content.val;
973    toss(env); if(env->err) return;    toss(env); if(env->err) return;
974    push_int(env, a+b);    push_int(env, a+b);
975  }  }
# Line 953  extern void sx_2d(environment *env) { Line 990  extern void sx_2d(environment *env) {
990      env->err=2;      env->err=2;
991      return;      return;
992    }    }
993    
994    a=env->head->item->content.val;    a=env->head->item->content.val;
995    toss(env); if(env->err) return;    toss(env); if(env->err) return;
996    b=env->head->item->content.val;    b=env->head->item->content.val;
# Line 976  extern void sx_3e(environment *env) { Line 1014  extern void sx_3e(environment *env) {
1014      env->err=2;      env->err=2;
1015      return;      return;
1016    }    }
1017    
1018    a=env->head->item->content.val;    a=env->head->item->content.val;
1019    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1020    b=env->head->item->content.val;    b=env->head->item->content.val;
# Line 987  extern void sx_3e(environment *env) { Line 1026  extern void sx_3e(environment *env) {
1026  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value){
1027    stackitem *old_item, *new_item, *prev_item;    stackitem *old_item, *new_item, *prev_item;
1028    
1029    value *new_value=new_val(env);    value *new_value= new_val(env);
1030    
1031    new_value->type=old_value->type;    protect(env, old_value);
1032      new_value->type= old_value->type;
1033    
1034    switch(old_value->type){    switch(old_value->type){
1035    case integer:    case integer:
1036      new_value->content.val=old_value->content.val;      new_value->content.val= old_value->content.val;
1037      break;      break;
1038    case string:    case string:
1039      (char *)(new_value->content.ptr)      (char *)(new_value->content.ptr)=
1040        = strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1041      break;      break;
1042    case func:    case func:
1043    case symb:    case symb:
1044      new_value->content.ptr=old_value->content.ptr;      new_value->content.ptr= old_value->content.ptr;
1045      break;      break;
1046    case list:    case list:
1047      new_value->content.ptr=NULL;      new_value->content.ptr= NULL;
1048    
1049      prev_item=NULL;      prev_item= NULL;
1050      old_item=(stackitem *)(old_value->content.ptr);      old_item= (stackitem*)(old_value->content.ptr);
1051    
1052      while(old_item != NULL) {   /* While list is not empty */      while(old_item != NULL) {   /* While list is not empty */
1053        new_item= malloc(sizeof(stackitem));        new_item= malloc(sizeof(stackitem));
1054        new_item->item=copy_val(env, old_item->item); /* recurse */        new_item->item= copy_val(env, old_item->item); /* recurse */
1055        new_item->next=NULL;        new_item->next= NULL;
1056        if(prev_item != NULL)     /* If this wasn't the first item */        if(prev_item != NULL)     /* If this wasn't the first item */
1057          prev_item->next=new_item; /* point the previous item to the          prev_item->next= new_item; /* point the previous item to the
1058                                       new item */                                       new item */
1059        else        else
1060          new_value->content.ptr=new_item;          new_value->content.ptr= new_item;
1061        old_item=old_item->next;        old_item= old_item->next;
1062        prev_item=new_item;        prev_item= new_item;
1063      }          }    
1064      break;      break;
1065    }    }
1066    
1067      unprotect(env);
1068    
1069    return new_value;    return new_value;
1070  }  }
1071    
# Line 1030  value *copy_val(environment *env, value Line 1073  value *copy_val(environment *env, value
1073  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env) {
1074    if((env->head)==NULL) {    if((env->head)==NULL) {
1075      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1076      env->err=1;      env->err= 1;
1077      return;      return;
1078    }    }
1079    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, env->head->item));
# Line 1043  extern void sx_6966(environment *env) { Line 1086  extern void sx_6966(environment *env) {
1086    
1087    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1088      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1089      env->err=1;      env->err= 1;
1090      return;      return;
1091    }    }
1092    
# Line 1116  extern void sx_7768696c65(environment *e Line 1159  extern void sx_7768696c65(environment *e
1159    }    }
1160    
1161    loop= env->head->item;    loop= env->head->item;
1162      protect(env, loop);
1163    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1164    
1165    test= env->head->item;    test= env->head->item;
1166      protect(env, test);
1167    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1168    
1169    do {    do {
# Line 1127  extern void sx_7768696c65(environment *e Line 1172  extern void sx_7768696c65(environment *e
1172            
1173      if(env->head->item->type != integer) {      if(env->head->item->type != integer) {
1174        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1175        env->err=2;        env->err= 2;
1176        return;        return;
1177      }      }
1178            
# Line 1142  extern void sx_7768696c65(environment *e Line 1187  extern void sx_7768696c65(environment *e
1187      }      }
1188        
1189    } while(truth);    } while(truth);
1190    
1191      unprotect(env); unprotect(env);
1192  }  }
1193    
1194    
# Line 1165  extern void sx_666f72(environment *env) Line 1212  extern void sx_666f72(environment *env)
1212    }    }
1213    
1214    loop= env->head->item;    loop= env->head->item;
1215      protect(env, loop);
1216    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1217    
1218    foo2= env->head->item->content.val;    foo2= env->head->item->content.val;
# Line 1188  extern void sx_666f72(environment *env) Line 1236  extern void sx_666f72(environment *env)
1236        foo1--;        foo1--;
1237      }      }
1238    }    }
1239      unprotect(env);
1240  }  }
1241    
1242  /* Variant of for-loop */  /* Variant of for-loop */
# Line 1198  extern void foreach(environment *env) { Line 1247  extern void foreach(environment *env) {
1247        
1248    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1249      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1250      env->err=1;      env->err= 1;
1251      return;      return;
1252    }    }
1253    
1254    if(env->head->next->item->type != list) {    if(env->head->next->item->type != list) {
1255      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1256      env->err=2;      env->err= 2;
1257      return;      return;
1258    }    }
1259    
1260    loop= env->head->item;    loop= env->head->item;
1261      protect(env, loop);
1262    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1263    
1264    foo= env->head->item;    foo= env->head->item;
1265      protect(env, foo);
1266    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1267    
1268    iterator= foo->content.ptr;    iterator= foo->content.ptr;
# Line 1222  extern void foreach(environment *env) { Line 1273  extern void foreach(environment *env) {
1273      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1274      iterator= iterator->next;      iterator= iterator->next;
1275    }    }
1276      unprotect(env); unprotect(env);
1277  }  }
1278    
1279  /* "to" */  /* "to" */
# Line 1282  extern void sx_72656164(environment *env Line 1334  extern void sx_72656164(environment *env
1334    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1335    const char intform[]= "%i%n";    const char intform[]= "%i%n";
1336    const char blankform[]= "%*[ \t]%n";    const char blankform[]= "%*[ \t]%n";
1337    const char ebrackform[]= "%*1[]]%n";    const char ebrackform[]= "]%n";
1338    const char semicform[]= "%*1[;]%n";    const char semicform[]= ";%n";
1339    const char bbrackform[]= "%*1[[]%n";    const char bbrackform[]= "[%n";
1340    
1341    int itemp, readlength= -1;    int itemp, readlength= -1;
1342    static int depth= 0;    static int depth= 0;
Legend:
Removed from v.1.89  
changed lines
  Added in v.1.90
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26