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

Diff of /stack/stack.c

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

revision 1.125 by teddy, Sun Mar 31 02:19:54 2002 UTC revision 1.126 by masse, Mon Aug 4 11:22:02 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 212  extern void gc_init(environment *env) Line 165  extern void gc_init(environment *env)
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 268  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 462  void push_sym(environment *env, const ch Line 424  void push_sym(environment *env, const ch
424    unprotect(new_value); unprotect(new_fvalue);    unprotect(new_value); unprotect(new_fvalue);
425  }  }
426    
 /* Print newline. */  
 extern void nl(environment *env)  
 {  
   printf("\n");  
 }  
   
 /* Print a newline to a port */  
 extern void nlport(environment *env)  
 {  
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=port) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   if(fprintf(CAR(env->head)->content.p, "\n") < 0){  
     perror("nl");  
     env->err= 5;  
     return;  
   }  
   toss(env);  
 }  
   
 /* 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;  
   case port:  
     push_sym(env, "port");  
     break;  
   }  
   swap(env);  
   if (env->err) return;  
   toss(env);  
 }  
   
427  /* Print a value */  /* Print a value */
428  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
429  {  {
# Line 682  void print_val(environment *env, value * Line 575  void print_val(environment *env, value *
575    }    }
576  }  }
577    
 /* Print the top element of the stack but don't discard it */  
 extern void print_(environment *env)  
 {  
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   print_val(env, CAR(env->head), 0, NULL, stdout);  
   if(env->err) return;  
   nl(env);  
 }  
   
 /* Prints the top element of the stack */  
 extern void print(environment *env)  
 {  
   print_(env);  
   if(env->err) return;  
   toss(env);  
 }  
   
 /* Print the top element of the stack without quotes, but don't  
    discard it. */  
 extern void princ_(environment *env)  
 {  
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   print_val(env, CAR(env->head), 1, NULL, stdout);  
 }  
   
 /* Prints the top element of the stack without quotes. */  
 extern void princ(environment *env)  
 {  
   princ_(env);  
   if(env->err) return;  
   toss(env);  
 }  
   
 /* Print a value to a port, but don't discard it */  
 extern void printport_(environment *env)  
 {  
   if(env->head->type==empty ||  CDR(env->head)->type == empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=port) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p);  
   if(env->err) return;  
   nlport(env);  
 }  
   
 /* Print a value to a port */  
 extern void printport(environment *env)  
 {  
   printport_(env);  
   if(env->err) return;  
   toss(env);  
 }  
   
 /* Print, without quotes, to a port, a value, but don't discard it. */  
 extern void princport_(environment *env)  
 {  
   if(env->head->type==empty ||  CDR(env->head)->type == empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=port) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p);  
   toss(env); if(env->err) return;  
 }  
   
 /* Print, without quotes, to a port, the top element. */  
 extern void princport(environment *env)  
 {  
   princport_(env);  
   if(env->err) return;  
   toss(env);  
 }  
   
 /* Only to be called by itself function printstack. */  
 void print_st(environment *env, value *stack_head, long counter)  
 {  
   if(CDR(stack_head)->type != empty)  
     print_st(env, CDR(stack_head), counter+1);  
   printf("%ld: ", counter);  
   print_val(env, CAR(stack_head), 0, NULL, stdout);  
   nl(env);  
 }  
   
 /* Prints the stack. */  
 extern void printstack(environment *env)  
 {  
   if(env->head->type == empty) {  
     printf("Stack Empty\n");  
     return;  
   }  
   
   print_st(env, env->head, 1);  
 }  
   
578  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
579  extern void swap(environment *env)  extern void swap(environment *env)
580  {  {
# Line 815  extern void swap(environment *env) Line 591  extern void swap(environment *env)
591    CDR(env->head)= temp;    CDR(env->head)= temp;
592  }  }
593    
 /* 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;  
 }  
   
594  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
595  extern void rcl(environment *env)  extern void rcl(environment *env)
596  {  {
# Line 862  extern void rcl(environment *env) Line 621  extern void rcl(environment *env)
621    if(env->err) return;    if(env->err) return;
622  }  }
623    
624    
625  /* 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
626     function value, and if it is, toss the symbol and execute the     function value, and if it is, toss the symbol and execute the
627     function. */     function. */
# Line 941  extern void eval(environment *env) Line 701  extern void eval(environment *env)
701    }    }
702  }  }
703    
704  /* Reverse (flip) a list */  /* List all defined words */
705  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)  
706  {  {
707    value *temp, *new_head;    symbol *temp;
708      int i;
709    /* Is top element a list? */    
710    if(env->head->type==empty) {    for(i= 0; i<HASHTBLSIZE; i++) {
711      printerr("Too Few Arguments");      temp= env->symbols[i];
712      env->err= 1;      while(temp!=NULL) {
713      return;  #ifdef DEBUG
714    }        if (temp->val != NULL && temp->val->gc.flag.protect)
715            printf("(protected) ");
716    if(CAR(env->head)->type!=tcons) {  #endif /* DEBUG */
717      printerr("Bad Argument Type");        printf("%s ", temp->id);
718      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;  
719      }      }
720    }    }
   
   /* Connect the tail of the list with the old stack head */  
   CDR(temp)= env->head;  
   env->head= new_head;          /* ...and voila! */  
   
721  }  }
722    
 /* 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);  
 }  
   
723  /* Quit stack. */  /* Quit stack. */
724  extern void quit(environment *env)  extern void quit(environment *env)
725  {  {
726    int i;    int i;
727    
728    clear(env);    while(env->head->type != empty)
729        toss(env);
730    
731    if (env->err) return;    if (env->err) return;
732    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
# Line 1157  extern void quit(environment *env) Line 751  extern void quit(environment *env)
751    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
752  }  }
753    
 /* 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;  
     }  
   }  
 }  
   
754  /* Internal forget function */  /* Internal forget function */
755  void forget_sym(symbol **hash_entry)  void forget_sym(symbol **hash_entry)
756  {  {
# Line 1195  void forget_sym(symbol **hash_entry) Line 763  void forget_sym(symbol **hash_entry)
763    free(temp);    free(temp);
764  }  }
765    
766  /* Forgets a symbol (remove it from the hash table) */  /* Only to be called by itself function printstack. */
767  extern void forget(environment *env)  void print_st(environment *env, value *stack_head, long counter)
768  {  {
769    char* sym_id;    if(CDR(stack_head)->type != empty)
770        print_st(env, CDR(stack_head), counter+1);
771      printf("%ld: ", counter);
772      print_val(env, CAR(stack_head), 0, NULL, stdout);
773      printf("\n");
774    }
775    
776    if(env->head->type==empty) {  /* Prints the stack. */
777      printerr("Too Few Arguments");  extern void printstack(environment *env)
778      env->err= 1;  {
779      return;    if(env->head->type == empty) {
780    }      printf("Stack Empty\n");
     
   if(CAR(env->head)->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
781      return;      return;
782    }    }
783    
784    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);  
785  }  }
786    
787  int main(int argc, char **argv)  int main(int argc, char **argv)
# Line 1277  under certain conditions; type 'copying; Line 837  under certain conditions; type 'copying;
837            printf("(error %d)\n", myenv.err);            printf("(error %d)\n", myenv.err);
838            myenv.err= 0;            myenv.err= 0;
839          }          }
840          nl(&myenv);          printf("\n");
841          printstack(&myenv);          printstack(&myenv);
842          printf("> ");          printf("> ");
843        }        }
844        myenv.err=0;        myenv.err=0;
845      }      }
846      sx_72656164(&myenv);        /* "read" */      readstream(&myenv, myenv.inputstream);
847      if (myenv.err) {            /* EOF or other error */      if (myenv.err) {            /* EOF or other error */
848        myenv.err=0;        myenv.err=0;
849        quit(&myenv);        quit(&myenv);
# Line 1300  under certain conditions; type 'copying; Line 860  under certain conditions; type 'copying;
860    return EXIT_FAILURE;    return EXIT_FAILURE;
861  }  }
862    
 /* "+" */  
 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);  
 }  
   
863  /* Return copy of a value */  /* Return copy of a value */
864  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
865  {  {
# Line 1561  value *copy_val(environment *env, value Line 898  value *copy_val(environment *env, value
898    return new_value;    return new_value;
899  }  }
900    
901  /* "dup"; duplicates an item on the stack */  /* read a line from a stream; used by readline */
902  extern void sx_647570(environment *env)  void readlinestream(environment *env, FILE *stream)
 {  
   if(env->head->type==empty) {  
     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);  
 }  
   
 /* "else" */  
 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)  
903  {  {
904    int truth;    char in_string[101];
   value *loop, *test;  
   
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   loop= CAR(env->head);  
   protect(loop);  
   toss(env); if(env->err) return;  
   
   test= CAR(env->head);  
   protect(test);  
   toss(env); if(env->err) return;  
905    
906    do {    if(fgets(in_string, 100, stream)==NULL) {
907      push_val(env, test);      push_cstring(env, "");
908      eval(env);      if (! feof(stream)){
909              perror("readline");
910      if(CAR(env->head)->type != integer) {        env->err= 5;
       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);  
911      }      }
912        } else {
913    } while(truth);      push_cstring(env, in_string);
914      }
   unprotect(loop); unprotect(test);  
915  }  }
916    
917    /* Reverse (flip) a list */
918  /* "for"; for-loop */  extern void rev(environment *env)
 extern void sx_666f72(environment *env)  
919  {  {
920    value *loop;    value *old_head, *new_head, *item;
   int foo1, foo2;  
921    
922    if(env->head->type==empty || CDR(env->head)->type==empty    if(env->head->type==empty) {
      || CDR(CDR(env->head))->type==empty) {  
923      printerr("Too Few Arguments");      printerr("Too Few Arguments");
924      env->err= 1;      env->err= 1;
925      return;      return;
926    }    }
927    
928    if(CAR(CDR(env->head))->type!=integer    if(CAR(env->head)->type==empty)
929       || 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;  
   }  
930    
931    if(CAR(CDR(env->head))->type!=tcons) {    if(CAR(env->head)->type!=tcons) {
932      printerr("Bad Argument Type");      printerr("Bad Argument Type");
933      env->err= 2;      env->err= 2;
934      return;      return;
935    }    }
936    
937    loop= CAR(env->head);    old_head= CAR(env->head);
938    protect(loop);    new_head= new_val(env);
939    toss(env); if(env->err) return;    while(old_head->type != empty) {
940        item= old_head;
941    foo= CAR(env->head);      old_head= CDR(old_head);
942    protect(foo);      CDR(item)= new_head;
943    toss(env); if(env->err) return;      new_head= item;
   
   iterator= foo;  
   
   while(iterator->type!=empty) {  
     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;  
     }  
944    }    }
945    unprotect(loop); unprotect(foo);    CAR(env->head)= new_head;
946  }  }
947    
948  /* "to" */  /* Make a list. */
949  extern void to(environment *env)  extern void pack(environment *env)
950  {  {
951    int ending, start, i;    value *iterator, *temp, *ending;
   value *iterator, *temp, *end;  
   
   end= new_val(env);  
   
   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;  
   }  
   
   ending= CAR(env->head)->content.i;  
   toss(env); if(env->err) return;  
   start= CAR(env->head)->content.i;  
   toss(env); if(env->err) return;  
   
   push_sym(env, "[");  
952    
953    if(ending>=start) {    ending=new_val(env);
     for(i= ending; i>=start; i--)  
       push_int(env, i);  
   } else {  
     for(i= ending; i<=start; i++)  
       push_int(env, i);  
   }  
954    
955    iterator= env->head;    iterator= env->head;
956      if(iterator->type == empty
   if(iterator->type==empty  
957       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
958           && CAR(iterator)->content.sym->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
959      temp= end;      temp= ending;
960      toss(env);      toss(env);
961    } else {    } else {
962      /* Search for first delimiter */      /* Search for first delimiter */
963      while(CDR(iterator)->type!=empty      while(CDR(iterator)->type != empty
964            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
965                || CAR(CDR(iterator))->content.sym->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
966        iterator= CDR(iterator);        iterator= CDR(iterator);
967            
968      /* Extract list */      /* Extract list */
969      temp= env->head;      temp= env->head;
970      env->head= CDR(iterator);      env->head= CDR(iterator);
971      CDR(iterator)= end;      CDR(iterator)= ending;
972    
973      if(env->head->type!=empty)      if(env->head->type != empty)
974        toss(env);        toss(env);
975    }    }
976    
977    /* Push list */    /* Push list */
   push_val(env, temp);  
 }  
   
 /* Read a string */  
 extern void readline(environment *env)  
 {  
   readlinestream(env, env->inputstream);  
 }  
   
 /* Read a string from a port */  
 extern void readlineport(environment *env)  
 {  
   FILE *stream;  
   
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
978    
979    if(CAR(env->head)->type!=port) {    push_val(env, temp);
980      printerr("Bad Argument Type");    rev(env);
     env->err= 2;  
     return;  
   }  
   
   stream=CAR(env->head)->content.p;  
   readlinestream(env, stream); if(env->err) return;  
   
   swap(env); if(env->err) return;  
   toss(env);  
 }  
   
 /* read a line from a stream; used by readline */  
 void readlinestream(environment *env, FILE *stream)  
 {  
   char in_string[101];  
   
   if(fgets(in_string, 100, stream)==NULL) {  
     push_cstring(env, "");  
     if (! feof(stream)){  
       perror("readline");  
       env->err= 5;  
     }  
   } else {  
     push_cstring(env, in_string);  
   }  
 }  
   
 /* "read"; Read a value and place on stack */  
 extern void sx_72656164(environment *env)  
 {  
   readstream(env, env->inputstream);  
 }  
   
 /* "readport"; Read a value from a port and place on stack */  
 extern void readport(environment *env)  
 {  
   FILE *stream;  
   
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=port) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   stream=CAR(env->head)->content.p;  
   readstream(env, stream); if(env->err) return;  
   
   swap(env); if(env->err) return;  
   toss(env);  
981  }  }
982    
983  /* read from a stream; used by "read" and "readport" */  /* read from a stream; used by "read" and "readport" */
# Line 1982  void readstream(environment *env, FILE * Line 1003  void readstream(environment *env, FILE *
1003      if(depth > 0 && env->interactive) {      if(depth > 0 && env->interactive) {
1004        printf("]> ");        printf("]> ");
1005      }      }
1006      readline(env); if(env->err) return;      readlinestream(env, env->inputstream);
1007        if(env->err) return;
1008    
1009      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1010        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
# Line 2042  void readstream(environment *env, FILE * Line 1064  void readstream(environment *env, FILE *
1064    free(match);    free(match);
1065    
1066    if(depth)    if(depth)
1067      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);  
1068  }  }
1069    
1070  extern void copying(environment *env)  extern void copying(environment *env)
# Line 2398  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER Line 1352  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER
1352  POSSIBILITY OF SUCH DAMAGES.\n");  POSSIBILITY OF SUCH DAMAGES.\n");
1353  }  }
1354    
 /* "*" */  
 extern void sx_2a(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)  
 {  
   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)=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);  
 }  
   
   
1355  /* General assoc function */  /* General assoc function */
1356  void assocgen(environment *env, funcp eqfunc)  void assocgen(environment *env, funcp eqfunc)
1357  {  {
# Line 2746  void assocgen(environment *env, funcp eq Line 1422  void assocgen(environment *env, funcp eq
1422    toss(env);    toss(env);
1423  }  }
1424    
1425  /* "do" */  /* Discard the top element of the stack. */
1426  extern void sx_646f(environment *env)  extern void toss(environment *env)
 {  
   swap(env); if(env->err) return;  
   eval(env);  
 }  
   
 /* "open" */  
 /* 2: "file"                                    */  
 /* 1: "r"       =>      1: #<port 0x47114711>   */  
 extern void sx_6f70656e(environment *env)  
1427  {  {
1428    value *new_port;    if(env->head->type==empty) {
   FILE *stream;  
   
   if(env->head->type == empty || CDR(env->head)->type == empty) {  
1429      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1430      env->err=1;      env->err= 1;
     return;  
   }  
   
   if(CAR(env->head)->type != string  
      || CAR(CDR(env->head))->type != string) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   stream=fopen(CAR(CDR(env->head))->content.ptr,  
                CAR(env->head)->content.ptr);  
   
   if(stream == NULL) {  
     perror("open");  
     env->err= 5;  
1431      return;      return;
1432    }    }
1433      
1434    new_port=new_val(env);    env->head= CDR(env->head); /* Remove the top stack item */
   new_port->type=port;  
   new_port->content.p=stream;  
   
   push_val(env, new_port);  
   
   swap(env); if(env->err) return;  
   toss(env); if(env->err) return;  
   swap(env); if(env->err) return;  
   toss(env);  
1435  }  }
1436    
   
 /* "close" */  
 extern void sx_636c6f7365(environment *env)  
 {  
   int ret;  
   
   if(env->head->type == empty) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
   
   if(CAR(env->head)->type != port) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   ret= fclose(CAR(env->head)->content.p);  
   
   if(ret != 0){  
     perror("close");  
     env->err= 5;  
     return;  
   }  
   
   toss(env);  
 }  
Legend:
Removed from v.1.125  
changed lines
  Added in v.1.126
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26