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

Diff of /stack/stack.c

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

revision 1.120 by teddy, Thu Mar 21 03:19:32 2002 UTC revision 1.129 by masse, Mon Aug 4 14:13:16 2003 UTC
# Line 21  Line 21 
21               Teddy Hogeborn <teddy@fukt.bth.se>               Teddy Hogeborn <teddy@fukt.bth.se>
22  */  */
23    
 #define CAR(X) ((X)->content.c->car)  
 #define CDR(X) ((X)->content.c->cdr)  
   
 /* printf, sscanf, fgets, fprintf, fopen, perror */  
 #include <stdio.h>  
 /* exit, EXIT_SUCCESS, malloc, free */  
 #include <stdlib.h>  
 /* NULL */  
 #include <stddef.h>  
 /* dlopen, dlsym, dlerror */  
 #include <dlfcn.h>  
 /* strcmp, strcpy, strlen, strcat, strdup */  
 #include <string.h>  
 /* getopt, STDIN_FILENO, STDOUT_FILENO, usleep */  
 #include <unistd.h>  
 /* EX_NOINPUT, EX_USAGE */  
 #include <sysexits.h>  
 /* assert */  
 #include <assert.h>  
   
 #ifdef __linux__  
 /* mtrace, muntrace */  
 #include <mcheck.h>  
 /* ioctl */  
 #include <sys/ioctl.h>  
 /* KDMKTONE */  
 #include <linux/kd.h>  
 #endif /* __linux__ */  
   
24  #include "stack.h"  #include "stack.h"
25    
26  /* Initialize a newly created environment */  /* Initialize a newly created environment */
# Line 76  void printerr(const char* in_string) Line 47  void printerr(const char* in_string)
47    fprintf(stderr, "Err: %s\n", in_string);    fprintf(stderr, "Err: %s\n", in_string);
48  }  }
49    
 /* Discard the top element of the stack. */  
 extern void toss(environment *env)  
 {  
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   env->head= CDR(env->head); /* Remove the top stack item */  
 }  
   
50  /* 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. */
51  symbol **hash(hashtbl in_hashtbl, const char *in_string)  symbol **hash(hashtbl in_hashtbl, const char *in_string)
52  {  {
# Line 141  value* new_val(environment *env) Line 100  value* new_val(environment *env)
100    return nval;    return nval;
101  }  }
102    
103    
104  /* Mark values recursively.  /* Mark values recursively.
105     Marked values are not collected by the GC. */     Marked values are not collected by the GC. */
106  inline void gc_mark(value *val)  inline void gc_mark(value *val)
# Line 156  inline void gc_mark(value *val) Line 116  inline void gc_mark(value *val)
116    }    }
117  }  }
118    
 inline void gc_maybe(environment *env)  
 {  
   if(env->gc_count < env->gc_limit)  
     return;  
   else  
     return gc_init(env);  
 }  
119    
120  /* Start GC */  /* Start GC */
121  extern void gc_init(environment *env)  extern void gc_init(environment *env)
# Line 205  extern void gc_init(environment *env) Line 158  extern void gc_init(environment *env)
158        case tcons:        case tcons:
159          free(env->gc_ref->item->content.c);          free(env->gc_ref->item->content.c);
160          break;          break;
161          case port:
162        case empty:        case empty:
163        case integer:        case integer:
164        case tfloat:        case tfloat:
165        case func:        case func:
166        case symb:        case symb:
167          /* Symbol strings are freed when walking the hash table */          /* Symbol strings are freed when walking the hash table */
168            break;
169        }        }
170    
171        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
# Line 230  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 248  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 267  extern void gc_init(environment *env) Line 222  extern void gc_init(environment *env)
222    
223  }  }
224    
225    inline void gc_maybe(environment *env)
226    {
227      if(env->gc_count < env->gc_limit)
228        return;
229      else
230        return gc_init(env);
231    }
232    
233  /* Protect values from GC */  /* Protect values from GC */
234  void protect(value *val)  void protect(value *val)
235  {  {
# Line 337  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 383  extern void mangle(environment *env) Line 346  extern void mangle(environment *env)
346      return;      return;
347    }    }
348    
349    new_string=    new_string= mangle_str(CAR(env->head)->content.string);
     mangle_str((const char *)(CAR(env->head)->content.ptr));  
350    
351    toss(env);    toss(env);
352    if(env->err) return;    if(env->err) return;
# Line 449  void push_sym(environment *env, const ch Line 411  void push_sym(environment *env, const ch
411    
412      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
413        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
414        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.func= funcptr; /* Store function pointer */
415        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
416                                           function value */                                           function value */
417      }      }
# Line 461  void push_sym(environment *env, const ch Line 423  void push_sym(environment *env, const ch
423    unprotect(new_value); unprotect(new_fvalue);    unprotect(new_value); unprotect(new_fvalue);
424  }  }
425    
 /* Print newline. */  
 extern void nl()  
 {  
   printf("\n");  
 }  
   
 /* Gets the type of a value */  
 extern void type(environment *env)  
 {  
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   switch(CAR(env->head)->type){  
   case empty:  
     push_sym(env, "empty");  
     break;  
   case integer:  
     push_sym(env, "integer");  
     break;  
   case tfloat:  
     push_sym(env, "float");  
     break;  
   case string:  
     push_sym(env, "string");  
     break;  
   case symb:  
     push_sym(env, "symbol");  
     break;  
   case func:  
     push_sym(env, "function");  
     break;  
   case tcons:  
     push_sym(env, "pair");  
     break;  
   }  
   swap(env);  
   if (env->err) return;  
   toss(env);  
 }      
   
426  /* Print a value */  /* Print a value */
427  void print_val(value *val, int noquote, stackitem *stack)  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
428  {  {
429    stackitem *titem, *tstack;    stackitem *titem, *tstack;
430    int depth;    int depth;
431    
432    switch(val->type) {    switch(val->type) {
433    case empty:    case empty:
434      printf("[]");      if(fprintf(stream, "[]") < 0){
435          perror("print_val");
436          env->err= 5;
437          return;
438        }
439      break;      break;
440    case integer:    case integer:
441      printf("%d", val->content.i);      if(fprintf(stream, "%d", val->content.i) < 0){
442          perror("print_val");
443          env->err= 5;
444          return;
445        }
446      break;      break;
447    case tfloat:    case tfloat:
448      printf("%f", val->content.f);      if(fprintf(stream, "%f", val->content.f) < 0){
449          perror("print_val");
450          env->err= 5;
451          return;
452        }
453      break;      break;
454    case string:    case string:
455      if(noquote)      if(noquote){
456        printf("%s", (char*)(val->content.ptr));        if(fprintf(stream, "%s", val->content.string) < 0){
457      else          perror("print_val");
458        printf("\"%s\"", (char*)(val->content.ptr));          env->err= 5;
459            return;
460          }
461        } else {                    /* quote */
462          if(fprintf(stream, "\"%s\"", val->content.string) < 0){
463            perror("print_val");
464            env->err= 5;
465            return;
466          }
467        }
468      break;      break;
469    case symb:    case symb:
470      printf("%s", val->content.sym->id);      if(fprintf(stream, "%s", val->content.sym->id) < 0){
471          perror("print_val");
472          env->err= 5;
473          return;
474        }
475      break;      break;
476    case func:    case func:
477      printf("#<function %p>", (funcp)(val->content.ptr));      if(fprintf(stream, "#<function %p>", val->content.func) < 0){
478          perror("print_val");
479          env->err= 5;
480          return;
481        }
482        break;
483      case port:
484        if(fprintf(stream, "#<port %p>", val->content.p) < 0){
485          perror("print_val");
486          env->err= 5;
487          return;
488        }
489      break;      break;
490    case tcons:    case tcons:
491      printf("[ ");      if(fprintf(stream, "[ ") < 0){
492          perror("print_val");
493          env->err= 5;
494          return;
495        }
496      tstack= stack;      tstack= stack;
497      do {      do {
498        titem=malloc(sizeof(stackitem));        titem=malloc(sizeof(stackitem));
# Line 550  void print_val(value *val, int noquote, Line 509  void print_val(value *val, int noquote,
509          depth++;          depth++;
510        }        }
511        if(titem != NULL){        /* If we found it on the stack, */        if(titem != NULL){        /* If we found it on the stack, */
512          printf("#%d#", depth);  /* print a depth reference */          if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
513              perror("print_val");
514              env->err= 5;
515              free(titem);
516              return;
517            }
518        } else {        } else {
519          print_val(CAR(val), noquote, tstack);          print_val(env, CAR(val), noquote, tstack, stream);
520        }        }
521        val= CDR(val);        val= CDR(val);
522        switch(val->type){        switch(val->type){
# Line 568  void print_val(value *val, int noquote, Line 532  void print_val(value *val, int noquote,
532            depth++;            depth++;
533          }          }
534          if(titem != NULL){      /* If we found it on the stack, */          if(titem != NULL){      /* If we found it on the stack, */
535            printf(" . #%d#", depth); /* print a depth reference */            if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
536                perror("print_val");
537                env->err= 5;
538                goto printval_end;
539              }
540          } else {          } else {
541            printf(" ");            if(fprintf(stream, " ") < 0){
542                perror("print_val");
543                env->err= 5;
544                goto printval_end;
545              }
546          }          }
547          break;          break;
548        default:        default:
549          printf(" . ");          /* Improper list */          if(fprintf(stream, " . ") < 0){ /* Improper list */
550          print_val(val, noquote, tstack);            perror("print_val");
551              env->err= 5;
552              goto printval_end;
553            }
554            print_val(env, val, noquote, tstack, stream);
555        }        }
556      } while(val->type == tcons && titem == NULL);      } while(val->type == tcons && titem == NULL);
557    
558      printval_end:
559    
560      titem=tstack;      titem=tstack;
561      while(titem != stack){      while(titem != stack){
562        tstack=titem->next;        tstack=titem->next;
563        free(titem);        free(titem);
564        titem=tstack;        titem=tstack;
565      }      }
     printf(" ]");  
     break;  
   }  
 }  
   
 extern void print_(environment *env)  
 {  
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   print_val(CAR(env->head), 0, NULL);  
   nl();  
 }  
   
 /* Prints the top element of the stack and then discards it. */  
 extern void print(environment *env)  
 {  
   print_(env);  
   if(env->err) return;  
   toss(env);  
 }  
   
 extern void princ_(environment *env)  
 {  
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   print_val(CAR(env->head), 1, NULL);  
 }  
   
 /* Prints the top element of the stack and then discards it. */  
 extern void princ(environment *env)  
 {  
   princ_(env);  
   if(env->err) return;  
   toss(env);  
 }  
   
 /* Only to be called by function printstack. */  
 void print_st(value *stack_head, long counter)  
 {  
   if(CDR(stack_head)->type != empty)  
     print_st(CDR(stack_head), counter+1);  
   printf("%ld: ", counter);  
   print_val(CAR(stack_head), 0, NULL);  
   nl();  
 }  
566    
567  /* Prints the stack. */      if(! (env->err)){
568  extern void printstack(environment *env)        if(fprintf(stream, " ]") < 0){
569  {          perror("print_val");
570    if(env->head->type == empty) {          env->err= 5;
571      printf("Stack Empty\n");        }
572      return;      }
573        break;
574    }    }
   
   print_st(env->head, 1);  
575  }  }
576    
577  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
# Line 663  extern void swap(environment *env) Line 590  extern void swap(environment *env)
590    CDR(env->head)= temp;    CDR(env->head)= temp;
591  }  }
592    
 /* Rotate the first three elements on the stack. */  
 extern void rot(environment *env)  
 {  
   value *temp= env->head;  
     
   if(env->head->type == empty || CDR(env->head)->type == empty  
      || CDR(CDR(env->head))->type == empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   env->head= CDR(CDR(env->head));  
   CDR(CDR(temp))= CDR(env->head);  
   CDR(env->head)= temp;  
 }  
   
593  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
594  extern void rcl(environment *env)  extern void rcl(environment *env)
595  {  {
# Line 710  extern void rcl(environment *env) Line 620  extern void rcl(environment *env)
620    if(env->err) return;    if(env->err) return;
621  }  }
622    
623    
624  /* 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
625     function value, and if it is, toss the symbol and execute the     function value, and if it is, toss the symbol and execute the
626     function. */     function. */
# Line 741  extern void eval(environment *env) Line 652  extern void eval(environment *env)
652    
653      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
654    case func:    case func:
655      in_func= (funcp)(CAR(env->head)->content.ptr);      in_func= CAR(env->head)->content.func;
656      toss(env);      toss(env);
657      if(env->err) return;      if(env->err) return;
658      return in_func(env);      return in_func(env);
# Line 780  extern void eval(environment *env) Line 691  extern void eval(environment *env)
691      return;      return;
692    
693    case empty:    case empty:
694        toss(env);
695    case integer:    case integer:
696    case tfloat:    case tfloat:
697    case string:    case string:
698      case port:
699      return;      return;
700    }    }
701  }  }
702    
703  /* Reverse (flip) a list */  /* List all defined words */
704  extern void rev(environment *env)  extern void words(environment *env)
 {  
   value *old_head, *new_head, *item;  
   
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type==empty)  
     return;                     /* Don't reverse an empty list */  
   
   if(CAR(env->head)->type!=tcons) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   old_head= CAR(env->head);  
   new_head= new_val(env);  
   while(old_head->type != empty) {  
     item= old_head;  
     old_head= CDR(old_head);  
     CDR(item)= new_head;  
     new_head= item;  
   }  
   CAR(env->head)= new_head;  
 }  
   
 /* Make a list. */  
 extern void pack(environment *env)  
 {  
   value *iterator, *temp, *ending;  
   
   ending=new_val(env);  
   
   iterator= env->head;  
   if(iterator->type == empty  
      || (CAR(iterator)->type==symb  
      && CAR(iterator)->content.sym->id[0]=='[')) {  
     temp= ending;  
     toss(env);  
   } else {  
     /* Search for first delimiter */  
     while(CDR(iterator)->type != empty  
           && (CAR(CDR(iterator))->type!=symb  
            || CAR(CDR(iterator))->content.sym->id[0]!='['))  
       iterator= CDR(iterator);  
       
     /* Extract list */  
     temp= env->head;  
     env->head= CDR(iterator);  
     CDR(iterator)= ending;  
   
     if(env->head->type != empty)  
       toss(env);  
   }  
   
   /* Push list */  
   
   push_val(env, temp);  
   rev(env);  
 }  
   
 /* Relocate elements of the list on the stack. */  
 extern void expand(environment *env)  
705  {  {
706    value *temp, *new_head;    symbol *temp;
707      int i;
708    /* Is top element a list? */    
709    if(env->head->type==empty) {    for(i= 0; i<HASHTBLSIZE; i++) {
710      printerr("Too Few Arguments");      temp= env->symbols[i];
711      env->err= 1;      while(temp!=NULL) {
712      return;  #ifdef DEBUG
713    }        if (temp->val != NULL && temp->val->gc.flag.protect)
714            printf("(protected) ");
715    if(CAR(env->head)->type!=tcons) {  #endif /* DEBUG */
716      printerr("Bad Argument Type");        printf("%s ", temp->id);
717      env->err= 2;        temp= temp->next;
     return;  
   }  
   
   rev(env);  
   
   if(env->err)  
     return;  
   
   /* The first list element is the new stack head */  
   new_head= temp= CAR(env->head);  
   
   toss(env);  
   
   /* Find the end of the list */  
   while(CDR(temp)->type != empty) {  
     if (CDR(temp)->type == tcons)  
       temp= CDR(temp);  
     else {  
       printerr("Bad Argument Type"); /* Improper list */  
       env->err= 2;  
       return;  
718      }      }
719    }    }
   
   /* Connect the tail of the list with the old stack head */  
   CDR(temp)= env->head;  
   env->head= new_head;          /* ...and voila! */  
   
720  }  }
721    
 /* Compares two elements by reference. */  
 extern void eq(environment *env)  
 {  
   void *left, *right;  
   
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   left= CAR(env->head)->content.ptr;  
   right= CAR(CDR(env->head))->content.ptr;  
   toss(env); toss(env);  
   
   push_int(env, left==right);  
 }  
   
 /* Negates the top element on the stack. */  
 extern void not(environment *env)  
 {  
   int val;  
   
   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;  
   }  
   
   val= CAR(env->head)->content.i;  
   toss(env);  
   push_int(env, !val);  
 }  
   
 /* Compares the two top elements on the stack and return 0 if they're the  
    same. */  
 extern void neq(environment *env)  
 {  
   eq(env);  
   not(env);  
 }  
   
 /* Give a symbol some content. */  
 extern void def(environment *env)  
 {  
   symbol *sym;  
   
   /* Needs two values on the stack, the top one must be a symbol */  
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   /* long names are a pain */  
   sym= CAR(env->head)->content.ptr;  
   
   /* Bind the symbol to the value */  
   sym->val= CAR(CDR(env->head));  
   
   toss(env); toss(env);  
 }  
   
722  /* Quit stack. */  /* Quit stack. */
723  extern void quit(environment *env)  extern void quit(environment *env)
724  {  {
725    int i;    int i;
726    
727    clear(env);    while(env->head->type != empty)
728        toss(env);
729    
730    if (env->err) return;    if (env->err) return;
731    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
# Line 1003  extern void quit(environment *env) Line 750  extern void quit(environment *env)
750    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
751  }  }
752    
 /* Clear stack */  
 extern void clear(environment *env)  
 {  
   while(env->head->type != empty)  
     toss(env);  
 }  
   
 /* List all defined words */  
 extern void words(environment *env)  
 {  
   symbol *temp;  
   int i;  
     
   for(i= 0; i<HASHTBLSIZE; i++) {  
     temp= env->symbols[i];  
     while(temp!=NULL) {  
 #ifdef DEBUG  
       if (temp->val != NULL && temp->val->gc.flag.protect)  
         printf("(protected) ");  
 #endif /* DEBUG */  
       printf("%s\n", temp->id);  
       temp= temp->next;  
     }  
   }  
 }  
   
753  /* Internal forget function */  /* Internal forget function */
754  void forget_sym(symbol **hash_entry)  void forget_sym(symbol **hash_entry)
755  {  {
# Line 1041  void forget_sym(symbol **hash_entry) Line 762  void forget_sym(symbol **hash_entry)
762    free(temp);    free(temp);
763  }  }
764    
765  /* Forgets a symbol (remove it from the hash table) */  /* Only to be called by itself function printstack. */
766  extern void forget(environment *env)  void print_st(environment *env, value *stack_head, long counter)
767  {  {
768    char* sym_id;    if(CDR(stack_head)->type != empty)
769        print_st(env, CDR(stack_head), counter+1);
770      printf("%ld: ", counter);
771      print_val(env, CAR(stack_head), 0, NULL, stdout);
772      printf("\n");
773    }
774    
775    if(env->head->type==empty) {  /* Prints the stack. */
776      printerr("Too Few Arguments");  extern void printstack(environment *env)
777      env->err= 1;  {
778      return;    if(env->head->type == empty) {
779    }      printf("Stack Empty\n");
     
   if(CAR(env->head)->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
780      return;      return;
781    }    }
782    
783    sym_id= CAR(env->head)->content.sym->id;    print_st(env, env->head, 1);
   toss(env);  
   
   return forget_sym(hash(env->symbols, sym_id));  
 }  
   
 /* Returns the current error number to the stack */  
 extern void errn(environment *env)  
 {  
   push_int(env, env->err);  
784  }  }
785    
786  int main(int argc, char **argv)  int main(int argc, char **argv)
# Line 1121  under certain conditions; type 'copying; Line 834  under certain conditions; type 'copying;
834        if (myenv.interactive) {        if (myenv.interactive) {
835          if(myenv.err) {          if(myenv.err) {
836            printf("(error %d)\n", myenv.err);            printf("(error %d)\n", myenv.err);
837              myenv.err= 0;
838          }          }
839          nl();          printf("\n");
840          printstack(&myenv);          printstack(&myenv);
841          printf("> ");          printf("> ");
842        }        }
843        myenv.err=0;        myenv.err=0;
844      }      }
845      sx_72656164(&myenv);        /* "read" */      readstream(&myenv, myenv.inputstream);
846      if (myenv.err==4) {         /* EOF */      if (myenv.err) {            /* EOF or other error */
847        myenv.err=0;        myenv.err=0;
848        quit(&myenv);        quit(&myenv);
849      } else if(myenv.head->type!=empty      } else if(myenv.head->type!=empty
850                && CAR(myenv.head)->type==symb                && CAR(myenv.head)->type==symb
851                && CAR(myenv.head)->content.sym->id[0]                && CAR(myenv.head)->content.sym->id[0] == ';') {
852                ==';') {        toss(&myenv); if(myenv.err) continue;
       toss(&myenv);             /* No error check in main */  
853        eval(&myenv);        eval(&myenv);
854        } else {
855          gc_maybe(&myenv);
856      }      }
     gc_maybe(&myenv);  
857    }    }
858    quit(&myenv);    quit(&myenv);
859    return EXIT_FAILURE;    return EXIT_FAILURE;
860  }  }
861    
 /* "+" */  
 extern void sx_2b(environment *env)  
 {  
   int a, b;  
   float fa, fb;  
   size_t len;  
   char* new_string;  
   value *a_val, *b_val;  
   
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type==string  
      && CAR(CDR(env->head))->type==string) {  
     a_val= CAR(env->head);  
     b_val= CAR(CDR(env->head));  
     protect(a_val); protect(b_val);  
     toss(env); if(env->err) return;  
     toss(env); if(env->err) return;  
     len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;  
     new_string= malloc(len);  
     assert(new_string != NULL);  
     strcpy(new_string, b_val->content.ptr);  
     strcat(new_string, a_val->content.ptr);  
     push_cstring(env, new_string);  
     unprotect(a_val); unprotect(b_val);  
     free(new_string);  
       
     return;  
   }  
     
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
     a= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     b= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b+a);  
   
     return;  
   }  
   
   if(CAR(env->head)->type==tfloat  
      && CAR(CDR(env->head))->type==tfloat) {  
     fa= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     fb= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb+fa);  
       
     return;  
   }  
   
   if(CAR(env->head)->type==tfloat  
      && CAR(CDR(env->head))->type==integer) {  
     fa= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     b= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     push_float(env, b+fa);  
       
     return;  
   }  
   
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==tfloat) {  
     a= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     fb= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb+a);  
   
     return;  
   }  
   
   printerr("Bad Argument Type");  
   env->err=2;  
 }  
   
 /* "-" */  
 extern void sx_2d(environment *env)  
 {  
   int a, b;  
   float fa, fb;  
   
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
     
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
     a= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     b= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b-a);  
   
     return;  
   }  
   
   if(CAR(env->head)->type==tfloat  
      && CAR(CDR(env->head))->type==tfloat) {  
     fa= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     fb= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb-fa);  
       
     return;  
   }  
   
   if(CAR(env->head)->type==tfloat  
      && CAR(CDR(env->head))->type==integer) {  
     fa= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     b= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     push_float(env, b-fa);  
       
     return;  
   }  
   
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==tfloat) {  
     a= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     fb= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb-a);  
   
     return;  
   }  
   
   printerr("Bad Argument Type");  
   env->err=2;  
 }  
   
 /* ">" */  
 extern void sx_3e(environment *env)  
 {  
   int a, b;  
   float fa, fb;  
   
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
     a= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     b= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b>a);  
   
     return;  
   }  
   
   if(CAR(env->head)->type==tfloat  
      && CAR(CDR(env->head))->type==tfloat) {  
     fa= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     fb= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     push_int(env, fb>fa);  
       
     return;  
   }  
   
   if(CAR(env->head)->type==tfloat  
      && CAR(CDR(env->head))->type==integer) {  
     fa= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     b= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b>fa);  
       
     return;  
   }  
   
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==tfloat) {  
     a= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     fb= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     push_int(env, fb>a);  
   
     return;  
   }  
   
   printerr("Bad Argument Type");  
   env->err= 2;  
 }  
   
 /* "<" */  
 extern void sx_3c(environment *env)  
 {  
   swap(env); if(env->err) return;  
   sx_3e(env);  
 }  
   
 /* "<=" */  
 extern void sx_3c3d(environment *env)  
 {  
   sx_3e(env); if(env->err) return;  
   not(env);  
 }  
   
 /* ">=" */  
 extern void sx_3e3d(environment *env)  
 {  
   sx_3c(env); if(env->err) return;  
   not(env);  
 }  
   
862  /* Return copy of a value */  /* Return copy of a value */
863  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
864  {  {
# Line 1376  value *copy_val(environment *env, value Line 867  value *copy_val(environment *env, value
867    if(old_value==NULL)    if(old_value==NULL)
868      return NULL;      return NULL;
869    
   protect(old_value);  
870    new_value= new_val(env);    new_value= new_val(env);
871    new_value->type= old_value->type;    new_value->type= old_value->type;
872    
# Line 1386  value *copy_val(environment *env, value Line 876  value *copy_val(environment *env, value
876    case func:    case func:
877    case symb:    case symb:
878    case empty:    case empty:
879      case port:
880      new_value->content= old_value->content;      new_value->content= old_value->content;
881      break;      break;
882    case string:    case string:
883      (char *)(new_value->content.ptr)=      new_value->content.string= strdup(old_value->content.string);
       strdup((char *)(old_value->content.ptr));  
884      break;      break;
885    case tcons:    case tcons:
886    
# Line 1403  value *copy_val(environment *env, value Line 893  value *copy_val(environment *env, value
893      break;      break;
894    }    }
895    
   unprotect(old_value);  
   
896    return new_value;    return new_value;
897  }  }
898    
899  /* "dup"; duplicates an item on the stack */  /* read a line from a stream; used by readline */
900  extern void sx_647570(environment *env)  void readlinestream(environment *env, FILE *stream)
901  {  {
902    if(env->head->type==empty) {    char in_string[101];
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   push_val(env, copy_val(env, CAR(env->head)));  
 }  
   
 /* "if", If-Then */  
 extern void sx_6966(environment *env)  
 {  
   int truth;  
   
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(CDR(env->head))->type != integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
     
   swap(env);  
   if(env->err) return;  
     
   truth= CAR(env->head)->content.i;  
   
   toss(env);  
   if(env->err) return;  
   
   if(truth)  
     eval(env);  
   else  
     toss(env);  
 }  
   
 /* If-Then-Else */  
 extern void ifelse(environment *env)  
 {  
   int truth;  
   
   if(env->head->type==empty || CDR(env->head)->type==empty  
      || CDR(CDR(env->head))->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(CDR(CDR(env->head)))->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
     
   rot(env);  
   if(env->err) return;  
     
   truth= CAR(env->head)->content.i;  
   
   toss(env);  
   if(env->err) return;  
   
   if(!truth)  
     swap(env);  
   if(env->err) return;  
   
   toss(env);  
   if(env->err) return;  
   
   eval(env);  
 }  
   
 extern void sx_656c7365(environment *env)  
 {  
   if(env->head->type==empty || CDR(env->head)->type==empty  
      || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty  
      || CDR(CDR(CDR(CDR(env->head))))->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(CDR(env->head))->type!=symb  
      || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0  
      || CAR(CDR(CDR(CDR(env->head))))->type!=symb  
      || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   swap(env); toss(env); rot(env); toss(env);  
   ifelse(env);  
 }  
   
 extern void then(environment *env)  
 {  
   if(env->head->type==empty || CDR(env->head)->type==empty  
      || CDR(CDR(env->head))->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(CDR(env->head))->type!=symb  
      || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   swap(env); toss(env);  
   sx_6966(env);  
 }  
   
 /* "while" */  
 extern void sx_7768696c65(environment *env)  
 {  
   int truth;  
   value *loop, *test;  
   
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
903    
904    loop= CAR(env->head);    if(fgets(in_string, 100, stream)==NULL) {
905    protect(loop);      push_cstring(env, "");
906    toss(env); if(env->err) return;      if (! feof(stream)){
907          perror("readline");
908    test= CAR(env->head);        env->err= 5;
   protect(test);  
   toss(env); if(env->err) return;  
   
   do {  
     push_val(env, test);  
     eval(env);  
       
     if(CAR(env->head)->type != integer) {  
       printerr("Bad Argument Type");  
       env->err= 2;  
       return;  
     }  
       
     truth= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
       
     if(truth) {  
       push_val(env, loop);  
       eval(env);  
     } else {  
       toss(env);  
909      }      }
910        } else {
911    } while(truth);      push_cstring(env, in_string);
912      }
   unprotect(loop); unprotect(test);  
913  }  }
914    
915    /* Reverse (flip) a list */
916  /* "for"; for-loop */  extern void rev(environment *env)
 extern void sx_666f72(environment *env)  
917  {  {
918    value *loop;    value *old_head, *new_head, *item;
   int foo1, foo2;  
919    
920    if(env->head->type==empty || CDR(env->head)->type==empty    if(env->head->type==empty) {
      || CDR(CDR(env->head))->type==empty) {  
921      printerr("Too Few Arguments");      printerr("Too Few Arguments");
922      env->err= 1;      env->err= 1;
923      return;      return;
924    }    }
925    
926    if(CAR(CDR(env->head))->type!=integer    if(CAR(env->head)->type==empty)
927       || CAR(CDR(CDR(env->head)))->type!=integer) {      return;                     /* Don't reverse an empty list */
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   loop= CAR(env->head);  
   protect(loop);  
   toss(env); if(env->err) return;  
   
   foo2= CAR(env->head)->content.i;  
   toss(env); if(env->err) return;  
   
   foo1= CAR(env->head)->content.i;  
   toss(env); if(env->err) return;  
   
   if(foo1<=foo2) {  
     while(foo1<=foo2) {  
       push_int(env, foo1);  
       push_val(env, loop);  
       eval(env); if(env->err) return;  
       foo1++;  
     }  
   } else {  
     while(foo1>=foo2) {  
       push_int(env, foo1);  
       push_val(env, loop);  
       eval(env); if(env->err) return;  
       foo1--;  
     }  
   }  
   unprotect(loop);  
 }  
   
 /* Variant of for-loop */  
 extern void foreach(environment *env)  
 {    
   value *loop, *foo;  
   value *iterator;  
     
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
928    
929    if(CAR(CDR(env->head))->type!=tcons) {    if(CAR(env->head)->type!=tcons) {
930      printerr("Bad Argument Type");      printerr("Bad Argument Type");
931      env->err= 2;      env->err= 2;
932      return;      return;
933    }    }
934    
935    loop= CAR(env->head);    old_head= CAR(env->head);
936    protect(loop);    new_head= new_val(env);
937    toss(env); if(env->err) return;    while(old_head->type != empty) {
938        item= old_head;
939    foo= CAR(env->head);      old_head= CDR(old_head);
940    protect(foo);      CDR(item)= new_head;
941    toss(env); if(env->err) return;      new_head= item;
   
   iterator= foo;  
   
   while(iterator!=NULL) {  
     push_val(env, CAR(iterator));  
     push_val(env, loop);  
     eval(env); if(env->err) return;  
     if (iterator->type == tcons){  
       iterator= CDR(iterator);  
     } else {  
       printerr("Bad Argument Type"); /* Improper list */  
       env->err= 2;  
       break;  
     }  
942    }    }
943    unprotect(loop); unprotect(foo);    CAR(env->head)= new_head;
944  }  }
945    
946  /* "to" */  /* Make a list. */
947  extern void to(environment *env)  extern void pack(environment *env)
948  {  {
949    int ending, start, i;    value *iterator, *temp, *ending;
   value *iterator, *temp;  
   
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=integer  
      || CAR(CDR(env->head))->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
950    
951    ending= CAR(env->head)->content.i;    ending=new_val(env);
   toss(env); if(env->err) return;  
   start= CAR(env->head)->content.i;  
   toss(env); if(env->err) return;  
   
   push_sym(env, "[");  
   
   if(ending>=start) {  
     for(i= ending; i>=start; i--)  
       push_int(env, i);  
   } else {  
     for(i= ending; i<=start; i++)  
       push_int(env, i);  
   }  
952    
953    iterator= env->head;    iterator= env->head;
954      if(iterator->type == empty
   if(iterator->type==empty  
955       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
956           && CAR(iterator)->content.sym->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
957      temp= NULL;      temp= ending;
958      toss(env);      toss(env);
959    } else {    } else {
960      /* Search for first delimiter */      /* Search for first delimiter */
961      while(CDR(iterator)!=NULL      while(CDR(iterator)->type != empty
962            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
963                || CAR(CDR(iterator))->content.sym->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
964        iterator= CDR(iterator);        iterator= CDR(iterator);
965            
966      /* Extract list */      /* Extract list */
967      temp= env->head;      temp= env->head;
968      env->head= CDR(iterator);      env->head= CDR(iterator);
969      CDR(iterator)= NULL;      CDR(iterator)= ending;
970    
971      if(env->head!=NULL)      if(env->head->type != empty)
972        toss(env);        toss(env);
973    }    }
974    
975    /* Push list */    /* Push list */
   push_val(env, temp);  
 }  
976    
977  /* Read a string */    push_val(env, temp);
978  extern void readline(environment *env)    rev(env);
 {  
   char in_string[101];  
   
   if(fgets(in_string, 100, env->inputstream)==NULL)  
     push_cstring(env, "");  
   else  
     push_cstring(env, in_string);  
979  }  }
980    
981  /* "read"; Read a value and place on stack */  /* read from a stream; used by "read" and "readport" */
982  extern void sx_72656164(environment *env)  void readstream(environment *env, FILE *stream)
983  {  {
984    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
985    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
# Line 1761  extern void sx_72656164(environment *env Line 1001  extern void sx_72656164(environment *env
1001      if(depth > 0 && env->interactive) {      if(depth > 0 && env->interactive) {
1002        printf("]> ");        printf("]> ");
1003      }      }
1004      readline(env); if(env->err) return;      readlinestream(env, env->inputstream);
1005        if(env->err) return;
1006    
1007      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){      if((CAR(env->head)->content.string)[0]=='\0'){
1008        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1009        return;        return;
1010      }      }
1011            
1012      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.string)+1);
1013      assert(env->in_string != NULL);      assert(env->in_string != NULL);
1014      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1015      strcpy(env->in_string, CAR(env->head)->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.string);
1016      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1017    }    }
1018        
# Line 1821  extern void sx_72656164(environment *env Line 1062  extern void sx_72656164(environment *env
1062    free(match);    free(match);
1063    
1064    if(depth)    if(depth)
1065      return sx_72656164(env);      return readstream(env, env->inputstream);
 }  
   
 #ifdef __linux__  
 extern void beep(environment *env)  
 {  
   int freq, dur, period, ticks;  
   
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=integer  
      || CAR(CDR(env->head))->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   dur= CAR(env->head)->content.i;  
   toss(env);  
   freq= CAR(env->head)->content.i;  
   toss(env);  
   
   period= 1193180/freq;         /* convert freq from Hz to period  
                                    length */  
   ticks= dur*.001193180;        /* convert duration from µseconds to  
                                    timer ticks */  
   
 /*    ticks=dur/1000; */  
   
       /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */  
   switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){  
   case 0:  
     usleep(dur);  
     return;  
   case -1:  
     perror("beep");  
     env->err= 5;  
     return;  
   default:  
     abort();  
   }  
 }  
 #endif /* __linux__ */  
   
 /* "wait" */  
 extern void sx_77616974(environment *env)  
 {  
   int dur;  
   
   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;  
   }  
   
   dur= CAR(env->head)->content.i;  
   toss(env);  
   
   usleep(dur);  
1066  }  }
1067    
1068  extern void copying(environment *env)  extern void copying(environment *env)
# Line 2177  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER Line 1350  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER
1350  POSSIBILITY OF SUCH DAMAGES.\n");  POSSIBILITY OF SUCH DAMAGES.\n");
1351  }  }
1352    
1353  /* "*" */  /* Discard the top element of the stack. */
1354  extern void sx_2a(environment *env)  extern void toss(environment *env)
 {  
   int a, b;  
   float fa, fb;  
   
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
     a= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     b= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b*a);  
   
     return;  
   }  
   
   if(CAR(env->head)->type==tfloat  
      && CAR(CDR(env->head))->type==tfloat) {  
     fa= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     fb= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb*fa);  
       
     return;  
   }  
   
   if(CAR(env->head)->type==tfloat  
      && CAR(CDR(env->head))->type==integer) {  
     fa= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     b= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     push_float(env, b*fa);  
       
     return;  
   }  
   
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==tfloat) {  
     a= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     fb= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb*a);  
   
     return;  
   }  
   
   printerr("Bad Argument Type");  
   env->err= 2;  
 }  
   
 /* "/" */  
 extern void sx_2f(environment *env)  
 {  
   int a, b;  
   float fa, fb;  
   
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
     a= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     b= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     push_float(env, b/a);  
   
     return;  
   }  
   
   if(CAR(env->head)->type==tfloat  
      && CAR(CDR(env->head))->type==tfloat) {  
     fa= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     fb= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb/fa);  
       
     return;  
   }  
   
   if(CAR(env->head)->type==tfloat  
      && CAR(CDR(env->head))->type==integer) {  
     fa= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     b= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     push_float(env, b/fa);  
       
     return;  
   }  
   
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==tfloat) {  
     a= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     fb= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb/a);  
   
     return;  
   }  
   
   printerr("Bad Argument Type");  
   env->err= 2;  
 }  
   
 /* "mod" */  
 extern void mod(environment *env)  
 {  
   int a, b;  
   
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
     a= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     b= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b%a);  
   
     return;  
   }  
   
   printerr("Bad Argument Type");  
   env->err= 2;  
 }  
   
 /* "div" */  
 extern void sx_646976(environment *env)  
 {  
   int a, b;  
     
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
     a= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     b= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, (int)b/a);  
   
     return;  
   }  
   
   printerr("Bad Argument Type");  
   env->err= 2;  
 }  
   
 extern void setcar(environment *env)  
 {  
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CDR(env->head)->type!=tcons) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   CAR(CAR(CDR(env->head)))=CAR(env->head);  
   toss(env);  
 }  
   
 extern void setcdr(environment *env)  
 {  
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CDR(env->head)->type!=tcons) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   CDR(CAR(CDR(env->head)))=CAR(env->head);  
   toss(env);  
 }  
   
 extern void car(environment *env)  
 {  
   if(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;  
   }  
   
   CAR(env->head)=CAR(CAR(env->head));  
 }  
   
 extern void cdr(environment *env)  
1355  {  {
1356    if(env->head->type==empty) {    if(env->head->type==empty) {
1357      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1358      env->err= 1;      env->err= 1;
1359      return;      return;
1360    }    }
1361      
1362    if(CAR(env->head)->type!=tcons) {    env->head= CDR(env->head); /* Remove the top stack item */
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   CAR(env->head)=CDR(CAR(env->head));  
 }  
   
 extern void cons(environment *env)  
 {  
   value *val;  
   
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   val=new_val(env);  
   val->content.c= malloc(sizeof(pair));  
   assert(val->content.c!=NULL);  
   
   env->gc_count += sizeof(pair);  
   val->type=tcons;  
   
   CAR(val)= CAR(CDR(env->head));  
   CDR(val)= CAR(env->head);  
   
   push_val(env, val);  
   
   swap(env); if(env->err) return;  
   toss(env); if(env->err) return;  
   swap(env); if(env->err) return;  
   toss(env); if(env->err) return;  
 }  
   
 /*  2: 3                        =>                */  
 /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */  
 extern void assq(environment *env)  
 {  
   assocgen(env, eq);  
1363  }  }
1364    
   
 /* 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);  
 }  
Legend:
Removed from v.1.120  
changed lines
  Added in v.1.129
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26