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

Diff of /stack/stack.c

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

revision 1.126 by masse, Mon Aug 4 11:22:02 2003 UTC revision 1.131 by masse, Tue Aug 5 09:09:51 2003 UTC
# Line 153  extern void gc_init(environment *env) Line 153  extern void gc_init(environment *env)
153        /* Remove content */        /* Remove content */
154        switch(env->gc_ref->item->type){        switch(env->gc_ref->item->type){
155        case string:        case string:
156          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.string);
157          break;          break;
158        case tcons:        case tcons:
159          free(env->gc_ref->item->content.c);          free(env->gc_ref->item->content.c);
# Line 185  extern void gc_init(environment *env) Line 185  extern void gc_init(environment *env)
185        printf(" integer: %d", env->gc_ref->item->content.i);        printf(" integer: %d", env->gc_ref->item->content.i);
186        break;        break;
187      case func:      case func:
188        printf(" func: %p", env->gc_ref->item->content.ptr);        printf(" func: %p", env->gc_ref->item->content.func);
189        break;        break;
190      case symb:      case symb:
191        printf(" symb: %s", env->gc_ref->item->content.sym->id);        printf(" symb: %s", env->gc_ref->item->content.sym->id);
192        break;        break;
193      case tcons:      case tcons:
194        printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,        printf(" tcons: %p\t%p", CAR(env->gc_ref->item),
195               env->gc_ref->item->content.c->cdr);               CDR(env->gc_ref->item));
196        break;        break;
197      default:      default:
198        printf(" <unknown %d>", (env->gc_ref->item->type));        printf(" <unknown %d>", (env->gc_ref->item->type));
# Line 203  extern void gc_init(environment *env) Line 203  extern void gc_init(environment *env)
203      /* Keep values */          /* Keep values */    
204      env->gc_count += sizeof(value);      env->gc_count += sizeof(value);
205      if(env->gc_ref->item->type==string)      if(env->gc_ref->item->type==string)
206        env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;        env->gc_count += strlen(env->gc_ref->item->content.string)+1;
207            
208      titem= env->gc_ref->next;      titem= env->gc_ref->next;
209      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
# Line 300  void push_cstring(environment *env, cons Line 300  void push_cstring(environment *env, cons
300    value *new_value= new_val(env);    value *new_value= new_val(env);
301    int length= strlen(in_string)+1;    int length= strlen(in_string)+1;
302    
303    new_value->content.ptr= malloc(length);    new_value->content.string= malloc(length);
304    assert(new_value != NULL);    assert(new_value != NULL);
305    env->gc_count += length;    env->gc_count += length;
306    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.string, in_string);
307    new_value->type= string;    new_value->type= string;
308    
309    push_val(env, new_value);    push_val(env, new_value);
# Line 330  char *mangle_str(const char *old_string) Line 330  char *mangle_str(const char *old_string)
330    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
331  }  }
332    
 extern void mangle(environment *env)  
 {  
   char *new_string;  
   
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=string) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   new_string=  
     mangle_str((const char *)(CAR(env->head)->content.ptr));  
   
   toss(env);  
   if(env->err) return;  
   
   push_cstring(env, new_string);  
 }  
   
333  /* Push a symbol onto the stack. */  /* Push a symbol onto the stack. */
334  void push_sym(environment *env, const char *in_string)  void push_sym(environment *env, const char *in_string)
335  {  {
# Line 380  void push_sym(environment *env, const ch Line 355  void push_sym(environment *env, const ch
355    
356    /* Look up the symbol name in the hash table */    /* Look up the symbol name in the hash table */
357    new_symbol= hash(env->symbols, in_string);    new_symbol= hash(env->symbols, in_string);
358    new_value->content.ptr= *new_symbol;    new_value->content.sym= *new_symbol;
359    
360    if(*new_symbol==NULL) { /* If symbol was undefined */    if(*new_symbol==NULL) { /* If symbol was undefined */
361    
# Line 394  void push_sym(environment *env, const ch Line 369  void push_sym(environment *env, const ch
369      strcpy((*new_symbol)->id, in_string);      strcpy((*new_symbol)->id, in_string);
370    
371      /* Intern the new symbol in the hash table */      /* Intern the new symbol in the hash table */
372      new_value->content.ptr= *new_symbol;      new_value->content.sym= *new_symbol;
373    
374      /* Try to load the symbol name as an external function, to see if      /* Try to load the symbol name as an external function, to see if
375         we should bind the symbol to a new function pointer value */         we should bind the symbol to a new function pointer value */
# Line 412  void push_sym(environment *env, const ch Line 387  void push_sym(environment *env, const ch
387    
388      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
389        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
390        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.func= funcptr; /* Store function pointer */
391        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
392                                           function value */                                           function value */
393      }      }
# Line 454  void print_val(environment *env, value * Line 429  void print_val(environment *env, value *
429      break;      break;
430    case string:    case string:
431      if(noquote){      if(noquote){
432        if(fprintf(stream, "%s", (char*)(val->content.ptr)) < 0){        if(fprintf(stream, "%s", val->content.string) < 0){
433          perror("print_val");          perror("print_val");
434          env->err= 5;          env->err= 5;
435          return;          return;
436        }        }
437      } else {                    /* quote */      } else {                    /* quote */
438        if(fprintf(stream, "\"%s\"", (char*)(val->content.ptr)) < 0){        if(fprintf(stream, "\"%s\"", val->content.string) < 0){
439          perror("print_val");          perror("print_val");
440          env->err= 5;          env->err= 5;
441          return;          return;
# Line 475  void print_val(environment *env, value * Line 450  void print_val(environment *env, value *
450      }      }
451      break;      break;
452    case func:    case func:
453      if(fprintf(stream, "#<function %p>", (funcp)(val->content.ptr)) < 0){      if(fprintf(stream, "#<function %p>", val->content.func) < 0){
454        perror("print_val");        perror("print_val");
455        env->err= 5;        env->err= 5;
456        return;        return;
457      }      }
458      break;      break;
459    case port:    case port:
460      if(fprintf(stream, "#<port %p>", (funcp)(val->content.p)) < 0){      if(fprintf(stream, "#<port %p>", val->content.p) < 0){
461        perror("print_val");        perror("print_val");
462        env->err= 5;        env->err= 5;
463        return;        return;
# Line 653  extern void eval(environment *env) Line 628  extern void eval(environment *env)
628    
629      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
630    case func:    case func:
631      in_func= (funcp)(CAR(env->head)->content.ptr);      in_func= CAR(env->head)->content.func;
632      toss(env);      toss(env);
633      if(env->err) return;      if(env->err) return;
634      return in_func(env);      return in_func(env);
# Line 881  value *copy_val(environment *env, value Line 856  value *copy_val(environment *env, value
856      new_value->content= old_value->content;      new_value->content= old_value->content;
857      break;      break;
858    case string:    case string:
859      (char *)(new_value->content.ptr)=      new_value->content.string= strdup(old_value->content.string);
       strdup((char *)(old_value->content.ptr));  
860      break;      break;
861    case tcons:    case tcons:
862    
# Line 1006  void readstream(environment *env, FILE * Line 980  void readstream(environment *env, FILE *
980      readlinestream(env, env->inputstream);      readlinestream(env, env->inputstream);
981      if(env->err) return;      if(env->err) return;
982    
983      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){      if((CAR(env->head)->content.string)[0]=='\0'){
984        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
985        return;        return;
986      }      }
987            
988      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.string)+1);
989      assert(env->in_string != NULL);      assert(env->in_string != NULL);
990      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
991      strcpy(env->in_string, CAR(env->head)->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.string);
992      toss(env); if(env->err) return;      toss(env); if(env->err) return;
993    }    }
994        
# Line 1352  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER Line 1326  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER
1326  POSSIBILITY OF SUCH DAMAGES.\n");  POSSIBILITY OF SUCH DAMAGES.\n");
1327  }  }
1328    
 /* General assoc function */  
 void assocgen(environment *env, funcp eqfunc)  
 {  
   value *key, *item;  
   
   /* Needs two values on the stack, the top one must be an association  
      list */  
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=tcons) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   key=CAR(CDR(env->head));  
   item=CAR(env->head);  
   
   while(item->type == tcons){  
     if(CAR(item)->type != tcons){  
       printerr("Bad Argument Type");  
       env->err= 2;  
       return;  
     }  
     push_val(env, key);  
     push_val(env, CAR(CAR(item)));  
     eqfunc(env); if(env->err) return;  
   
     /* Check the result of 'eqfunc' */  
     if(env->head->type==empty) {  
       printerr("Too Few Arguments");  
       env->err= 1;  
     return;  
     }  
     if(CAR(env->head)->type!=integer) {  
       printerr("Bad Argument Type");  
       env->err= 2;  
       return;  
     }  
   
     if(CAR(env->head)->content.i){  
       toss(env); if(env->err) return;  
       break;  
     }  
     toss(env); if(env->err) return;  
   
     if(item->type!=tcons) {  
       printerr("Bad Argument Type");  
       env->err= 2;  
       return;  
     }  
   
     item=CDR(item);  
   }  
   
   if(item->type == tcons){      /* A match was found */  
     push_val(env, CAR(item));  
   } else {  
     push_int(env, 0);  
   }  
   swap(env); if(env->err) return;  
   toss(env); if(env->err) return;  
   swap(env); if(env->err) return;  
   toss(env);  
 }  
   
1329  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
1330  extern void toss(environment *env)  extern void toss(environment *env)
1331  {  {
Legend:
Removed from v.1.126  
changed lines
  Added in v.1.131
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26