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

Diff of /stack/stack.c

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

revision 1.135 by masse, Wed Aug 13 11:58:00 2003 UTC revision 1.137 by masse, Thu Feb 19 15:35:38 2004 UTC
# Line 27  const char* start_message= "Stack versio Line 27  const char* start_message= "Stack versio
27  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
28  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
29  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
30  under certain conditions; type 'copying;' for details.\n";  under certain conditions; type 'copying;' for details.";
31    
32    
33  /* Initialize a newly created environment */  /* Initialize a newly created environment */
# Line 66  void printerr(environment *env) Line 66  void printerr(environment *env)
66    case 3:    case 3:
67      in_string= "Unbound Variable";      in_string= "Unbound Variable";
68      break;      break;
69      case 5:
70        return perror(env->errsymb);
71    default:    default:
72      in_string= "Unknown error";      in_string= "Unknown error";
73      break;      break;
# Line 130  value* new_val(environment *env) Line 132  value* new_val(environment *env)
132  }  }
133    
134    
 /* Mark values recursively.  
    Marked values are not collected by the GC. */  
 inline void gc_mark(value *val)  
 {  
   if(val==NULL || val->gc.flag.mark)  
     return;  
   
   val->gc.flag.mark= 1;  
   
   if(val->type==tcons) {  
     gc_mark(CAR(val));  
     gc_mark(CDR(val));  
   }  
 }  
   
   
 /* Start GC */  
 extern void gc_init(environment *env)  
 {  
   stackitem *new_head= NULL, *titem;  
   symbol *tsymb;  
   int i;  
   
   if(env->interactive)  
     printf("Garbage collecting.");  
   
   /* Mark values on stack */  
   gc_mark(env->head);  
   
   if(env->interactive)  
     printf(".");  
   
   /* Mark values in hashtable */  
   for(i= 0; i<HASHTBLSIZE; i++)  
     for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)  
       if (tsymb->val != NULL)  
         gc_mark(tsymb->val);  
   
   if(env->interactive)  
     printf(".");  
   
   env->gc_count= 0;  
   
   while(env->gc_ref!=NULL) {    /* Sweep unused values */  
     if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */  
   
       /* Remove content */  
       switch(env->gc_ref->item->type){  
       case string:  
         free(env->gc_ref->item->content.string);  
         break;  
       case tcons:  
         free(env->gc_ref->item->content.c);  
         break;  
       case port:  
       case empty:  
       case unknown:  
       case integer:  
       case tfloat:  
       case func:  
       case symb:  
         /* Symbol strings are freed when walking the hash table */  
         break;  
       }  
   
       free(env->gc_ref->item);  /* Remove from gc_ref */  
       titem= env->gc_ref->next;  
       free(env->gc_ref);        /* Remove value */  
       env->gc_ref= titem;  
       continue;  
     }  
   
 #ifdef DEBUG  
     printf("Kept value (%p)", env->gc_ref->item);  
     if(env->gc_ref->item->gc.flag.mark)  
       printf(" (marked)");  
     if(env->gc_ref->item->gc.flag.protect)  
       printf(" (protected)");  
     switch(env->gc_ref->item->type){  
     case integer:  
       printf(" integer: %d", env->gc_ref->item->content.i);  
       break;  
     case func:  
       printf(" func: %p", env->gc_ref->item->content.func);  
       break;  
     case symb:  
       printf(" symb: %s", env->gc_ref->item->content.sym->id);  
       break;  
     case tcons:  
       printf(" tcons: %p\t%p", CAR(env->gc_ref->item),  
              CDR(env->gc_ref->item));  
       break;  
     default:  
       printf(" <unknown %d>", (env->gc_ref->item->type));  
     }  
     printf("\n");  
 #endif /* DEBUG */  
   
     /* Keep values */      
     env->gc_count += sizeof(value);  
     if(env->gc_ref->item->type==string)  
       env->gc_count += strlen(env->gc_ref->item->content.string)+1;  
       
     titem= env->gc_ref->next;  
     env->gc_ref->next= new_head;  
     new_head= env->gc_ref;  
     new_head->item->gc.flag.mark= 0;  
     env->gc_ref= titem;  
   }  
   
   if (env->gc_limit < env->gc_count*2)  
     env->gc_limit= env->gc_count*2;  
   
   env->gc_ref= new_head;  
   
   if(env->interactive)  
     printf("done (%d bytes still allocated)\n", env->gc_count);  
   
 }  
   
   
 inline void gc_maybe(environment *env)  
 {  
   if(env->gc_count < env->gc_limit)  
     return;  
   else  
     return gc_init(env);  
 }  
   
   
 /* Protect values from GC */  
 void protect(value *val)  
 {  
   if(val==NULL || val->gc.flag.protect)  
     return;  
   
   val->gc.flag.protect= 1;  
   
   if(val->type==tcons) {  
     protect(CAR(val));  
     protect(CDR(val));  
   }  
 }  
   
   
 /* Unprotect values from GC */  
 void unprotect(value *val)  
 {  
   if(val==NULL || !(val->gc.flag.protect))  
     return;  
   
   val->gc.flag.protect= 0;  
   
   if(val->type==tcons) {  
     unprotect(CAR(val));  
     unprotect(CDR(val));  
   }  
 }  
   
   
135  /* Push a value onto the stack */  /* Push a value onto the stack */
136  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
137  {  {
# Line 444  void print_val(environment *env, value * Line 286  void print_val(environment *env, value *
286    
287    switch(val->type) {    switch(val->type) {
288    case empty:    case empty:
289      if(fprintf(stream, "[]") < 0){      if(fprintf(stream, "[]") < 0)
       perror("print_val");  
290        env->err= 5;        env->err= 5;
       return;  
     }  
291      break;      break;
292    case unknown:    case unknown:
293      if(fprintf(stream, "UNKNOWN") < 0){      if(fprintf(stream, "UNKNOWN") < 0)
       perror("print_val");  
294        env->err= 5;        env->err= 5;
       return;  
     }  
295      break;      break;
296    case integer:    case integer:
297      if(fprintf(stream, "%d", val->content.i) < 0){      if(fprintf(stream, "%d", val->content.i) < 0)
       perror("print_val");  
298        env->err= 5;        env->err= 5;
       return;  
     }  
299      break;      break;
300    case tfloat:    case tfloat:
301      if(fprintf(stream, "%f", val->content.f) < 0){      if(fprintf(stream, "%f", val->content.f) < 0)
       perror("print_val");  
302        env->err= 5;        env->err= 5;
       return;  
     }  
303      break;      break;
304    case string:    case string:
305      if(noquote){      if(noquote){
306        if(fprintf(stream, "%s", val->content.string) < 0){        if(fprintf(stream, "%s", val->content.string) < 0)
         perror("print_val");  
307          env->err= 5;          env->err= 5;
         return;  
       }  
308      } else {                    /* quote */      } else {                    /* quote */
309        if(fprintf(stream, "\"%s\"", val->content.string) < 0){        if(fprintf(stream, "\"%s\"", val->content.string) < 0)
         perror("print_val");  
310          env->err= 5;          env->err= 5;
         return;  
       }  
311      }      }
312      break;      break;
313    case symb:    case symb:
314      if(fprintf(stream, "%s", val->content.sym->id) < 0){      if(fprintf(stream, "%s", val->content.sym->id) < 0)
       perror("print_val");  
315        env->err= 5;        env->err= 5;
       return;  
     }  
316      break;      break;
317    case func:    case func:
318      if(fprintf(stream, "#<function %p>", val->content.func) < 0){      if(fprintf(stream, "#<function %p>", val->content.func) < 0)
       perror("print_val");  
319        env->err= 5;        env->err= 5;
       return;  
     }  
320      break;      break;
321    case port:    case port:
322      if(fprintf(stream, "#<port %p>", val->content.p) < 0){      if(fprintf(stream, "#<port %p>", val->content.p) < 0)
       perror("print_val");  
323        env->err= 5;        env->err= 5;
       return;  
     }  
324      break;      break;
325    case tcons:    case tcons:
326      if(fprintf(stream, "[ ") < 0){      if(fprintf(stream, "[ ") < 0) {
       perror("print_val");  
327        env->err= 5;        env->err= 5;
328        return;        return printerr(env);
329      }      }
330      tstack= stack;      tstack= stack;
331    
# Line 533  void print_val(environment *env, value * Line 347  void print_val(environment *env, value *
347    
348        if(titem != NULL){        /* If we found it on the stack, */        if(titem != NULL){        /* If we found it on the stack, */
349          if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */          if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
           perror("print_val");  
350            env->err= 5;            env->err= 5;
351            free(titem);            free(titem);
352            return;            return printerr(env);
353          }          }
354        } else {        } else {
355          print_val(env, CAR(val), noquote, tstack, stream);          print_val(env, CAR(val), noquote, tstack, stream);
# Line 558  void print_val(environment *env, value * Line 371  void print_val(environment *env, value *
371          }          }
372          if(titem != NULL){      /* If we found it on the stack, */          if(titem != NULL){      /* If we found it on the stack, */
373            if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */            if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
             perror("print_val");  
374              env->err= 5;              env->err= 5;
375                printerr(env);
376              goto printval_end;              goto printval_end;
377            }            }
378          } else {          } else {
379            if(fprintf(stream, " ") < 0){            if(fprintf(stream, " ") < 0){
             perror("print_val");  
380              env->err= 5;              env->err= 5;
381                printerr(env);
382              goto printval_end;              goto printval_end;
383            }            }
384          }          }
385          break;          break;
386        default:        default:
387          if(fprintf(stream, " . ") < 0){ /* Improper list */          if(fprintf(stream, " . ") < 0){ /* Improper list */
           perror("print_val");  
388            env->err= 5;            env->err= 5;
389              printerr(env);
390            goto printval_end;            goto printval_end;
391          }          }
392          print_val(env, val, noquote, tstack, stream);          print_val(env, val, noquote, tstack, stream);
# Line 591  void print_val(environment *env, value * Line 404  void print_val(environment *env, value *
404    
405      if(! (env->err)){      if(! (env->err)){
406        if(fprintf(stream, " ]") < 0){        if(fprintf(stream, " ]") < 0){
         perror("print_val");  
407          env->err= 5;          env->err= 5;
408        }        }
409      }      }
410      break;      break;
411    }    }
412      
413      if(env->err)
414        return printerr(env);
415  }  }
416    
417    
# Line 605  extern void swap(environment *env) Line 420  extern void swap(environment *env)
420  {  {
421    value *temp= env->head;    value *temp= env->head;
422    
423    if(check_args(env, unknown, unknown, empty))    if(check_args(env, 2, unknown, unknown))
424      return printerr(env);      return printerr(env);
425        
426    env->head= CDR(env->head);    env->head= CDR(env->head);
# Line 619  extern void rcl(environment *env) Line 434  extern void rcl(environment *env)
434  {  {
435    value *val;    value *val;
436    
437    if(check_args(env, symb, empty))    if(check_args(env, 1, symb))
438      return printerr(env);      return printerr(env);
439    
440    val= CAR(env->head)->content.sym->val;    val= CAR(env->head)->content.sym->val;
# Line 648  extern void eval(environment *env) Line 463  extern void eval(environment *env)
463    
464    gc_maybe(env);    gc_maybe(env);
465    
466    if(check_args(env, unknown, empty))    if(check_args(env, 1, unknown))
467      return printerr(env);      return printerr(env);
468    
469    switch(CAR(env->head)->type) {    switch(CAR(env->head)->type) {
# Line 843  void readlinestream(environment *env, FI Line 658  void readlinestream(environment *env, FI
658    if(fgets(in_string, 100, stream)==NULL) {    if(fgets(in_string, 100, stream)==NULL) {
659      push_cstring(env, "");      push_cstring(env, "");
660      if (! feof(stream)){      if (! feof(stream)){
       perror("readline");  
661        env->err= 5;        env->err= 5;
662          return printerr(env);
663      }      }
664    } else {    } else {
665      push_cstring(env, in_string);      push_cstring(env, in_string);
# Line 860  extern void rev(environment *env) Line 675  extern void rev(environment *env)
675    if(CAR(env->head)->type==empty)    if(CAR(env->head)->type==empty)
676      return;                     /* Don't reverse an empty list */      return;                     /* Don't reverse an empty list */
677    
678    if(check_args(env, tcons, empty))    if(check_args(env, 1, tcons))
679      return printerr(env);      return printerr(env);
680    
681    old_head= CAR(env->head);    old_head= CAR(env->head);
# Line 1000  void readstream(environment *env, FILE * Line 815  void readstream(environment *env, FILE *
815  }  }
816    
817    
818  int check_args(environment *env, ...)  int check_args(environment *env, int num_args, ...)
819  {  {
820    va_list ap;    va_list ap;
821    enum type_enum mytype;    enum type_enum mytype;
822      int i;
823    
824    value *iter= env->head;    value *iter= env->head;
825    int errval= 0;    int errval= 0;
826    
827    va_start(ap, env);    va_start(ap, num_args);
828    while(1) {    for(i=1; i<=num_args; i++) {
829      mytype= va_arg(ap, enum type_enum);      mytype= va_arg(ap, enum type_enum);
830      //    fprintf(stderr, "%s\n", env->errsymb);      //    fprintf(stderr, "%s\n", env->errsymb);
831    
     if(mytype==empty)  
       break;  
       
832      if(iter->type==empty || iter==NULL) {      if(iter->type==empty || iter==NULL) {
833        errval= 1;        errval= 1;
834        break;        break;
835      }      }
836    
837      if(mytype==unknown) {      if(mytype!=unknown && CAR(iter)->type!=mytype) {
       iter=CDR(iter);  
       continue;  
     }  
   
     if(CAR(iter)->type!=mytype) {  
838        errval= 2;        errval= 2;
839        break;        break;
840      }      }
Legend:
Removed from v.1.135  
changed lines
  Added in v.1.137
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26