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

Diff of /stack/stack.c

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

revision 1.118 by teddy, Wed Mar 20 13:20:29 2002 UTC revision 1.131 by masse, Tue Aug 5 09:09:51 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 200  extern void gc_init(environment *env) Line 153  extern void gc_init(environment *env)
153        /* Remove content */        /* Remove content */
154        switch(env->gc_ref->item->type){        switch(env->gc_ref->item->type){
155        case string:        case string:
156          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.string);
157          break;          break;
158        case tcons:        case tcons:
159          free(env->gc_ref->item->content.c);          free(env->gc_ref->item->content.c);
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 367  char *mangle_str(const char *old_string) Line 330  char *mangle_str(const char *old_string)
330    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
331  }  }
332    
 extern void mangle(environment *env)  
 {  
   char *new_string;  
   
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=string) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   new_string=  
     mangle_str((const char *)(CAR(env->head)->content.ptr));  
   
   toss(env);  
   if(env->err) return;  
   
   push_cstring(env, new_string);  
 }  
   
333  /* Push a symbol onto the stack. */  /* Push a symbol onto the stack. */
334  void push_sym(environment *env, const char *in_string)  void push_sym(environment *env, const char *in_string)
335  {  {
# Line 417  void push_sym(environment *env, const ch Line 355  void push_sym(environment *env, const ch
355    
356    /* Look up the symbol name in the hash table */    /* Look up the symbol name in the hash table */
357    new_symbol= hash(env->symbols, in_string);    new_symbol= hash(env->symbols, in_string);
358    new_value->content.ptr= *new_symbol;    new_value->content.sym= *new_symbol;
359    
360    if(*new_symbol==NULL) { /* If symbol was undefined */    if(*new_symbol==NULL) { /* If symbol was undefined */
361    
# Line 431  void push_sym(environment *env, const ch Line 369  void push_sym(environment *env, const ch
369      strcpy((*new_symbol)->id, in_string);      strcpy((*new_symbol)->id, in_string);
370    
371      /* Intern the new symbol in the hash table */      /* Intern the new symbol in the hash table */
372      new_value->content.ptr= *new_symbol;      new_value->content.sym= *new_symbol;
373    
374      /* Try to load the symbol name as an external function, to see if      /* Try to load the symbol name as an external function, to see if
375         we should bind the symbol to a new function pointer value */         we should bind the symbol to a new function pointer value */
# Line 449  void push_sym(environment *env, const ch Line 387  void push_sym(environment *env, const ch
387    
388      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
389        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
390        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.func= funcptr; /* Store function pointer */
391        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
392                                           function value */                                           function value */
393      }      }
# Line 461  void push_sym(environment *env, const ch Line 399  void push_sym(environment *env, const ch
399    unprotect(new_value); unprotect(new_fvalue);    unprotect(new_value); unprotect(new_fvalue);
400  }  }
401    
 /* 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);  
 }      
   
402  /* Print a value */  /* Print a value */
403  void print_val(value *val, int noquote, stackitem *stack)  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
404  {  {
405    stackitem *titem, *tstack;    stackitem *titem, *tstack;
406    int depth;    int depth;
407    
408    switch(val->type) {    switch(val->type) {
409    case empty:    case empty:
410      printf("[]");      if(fprintf(stream, "[]") < 0){
411          perror("print_val");
412          env->err= 5;
413          return;
414        }
415      break;      break;
416    case integer:    case integer:
417      printf("%d", val->content.i);      if(fprintf(stream, "%d", val->content.i) < 0){
418          perror("print_val");
419          env->err= 5;
420          return;
421        }
422      break;      break;
423    case tfloat:    case tfloat:
424      printf("%f", val->content.f);      if(fprintf(stream, "%f", val->content.f) < 0){
425          perror("print_val");
426          env->err= 5;
427          return;
428        }
429      break;      break;
430    case string:    case string:
431      if(noquote)      if(noquote){
432        printf("%s", (char*)(val->content.ptr));        if(fprintf(stream, "%s", val->content.string) < 0){
433      else          perror("print_val");
434        printf("\"%s\"", (char*)(val->content.ptr));          env->err= 5;
435            return;
436          }
437        } else {                    /* quote */
438          if(fprintf(stream, "\"%s\"", val->content.string) < 0){
439            perror("print_val");
440            env->err= 5;
441            return;
442          }
443        }
444      break;      break;
445    case symb:    case symb:
446      printf("%s", val->content.sym->id);      if(fprintf(stream, "%s", val->content.sym->id) < 0){
447          perror("print_val");
448          env->err= 5;
449          return;
450        }
451      break;      break;
452    case func:    case func:
453      printf("#<function %p>", (funcp)(val->content.ptr));      if(fprintf(stream, "#<function %p>", val->content.func) < 0){
454          perror("print_val");
455          env->err= 5;
456          return;
457        }
458        break;
459      case port:
460        if(fprintf(stream, "#<port %p>", val->content.p) < 0){
461          perror("print_val");
462          env->err= 5;
463          return;
464        }
465      break;      break;
466    case tcons:    case tcons:
467      printf("[ ");      if(fprintf(stream, "[ ") < 0){
468          perror("print_val");
469          env->err= 5;
470          return;
471        }
472      tstack= stack;      tstack= stack;
473      do {      do {
474        titem=malloc(sizeof(stackitem));        titem=malloc(sizeof(stackitem));
# Line 550  void print_val(value *val, int noquote, Line 485  void print_val(value *val, int noquote,
485          depth++;          depth++;
486        }        }
487        if(titem != NULL){        /* If we found it on the stack, */        if(titem != NULL){        /* If we found it on the stack, */
488          printf("#%d#", depth);  /* print a depth reference */          if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
489              perror("print_val");
490              env->err= 5;
491              free(titem);
492              return;
493            }
494        } else {        } else {
495          print_val(CAR(val), noquote, tstack);          print_val(env, CAR(val), noquote, tstack, stream);
496        }        }
497        val= CDR(val);        val= CDR(val);
498        switch(val->type){        switch(val->type){
# Line 568  void print_val(value *val, int noquote, Line 508  void print_val(value *val, int noquote,
508            depth++;            depth++;
509          }          }
510          if(titem != NULL){      /* If we found it on the stack, */          if(titem != NULL){      /* If we found it on the stack, */
511            printf(" . #%d#", depth); /* print a depth reference */            if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
512                perror("print_val");
513                env->err= 5;
514                goto printval_end;
515              }
516          } else {          } else {
517            printf(" ");            if(fprintf(stream, " ") < 0){
518                perror("print_val");
519                env->err= 5;
520                goto printval_end;
521              }
522          }          }
523          break;          break;
524        default:        default:
525          printf(" . ");          /* Improper list */          if(fprintf(stream, " . ") < 0){ /* Improper list */
526          print_val(val, noquote, tstack);            perror("print_val");
527              env->err= 5;
528              goto printval_end;
529            }
530            print_val(env, val, noquote, tstack, stream);
531        }        }
532      } while(val->type == tcons && titem == NULL);      } while(val->type == tcons && titem == NULL);
533    
534      printval_end:
535    
536      titem=tstack;      titem=tstack;
537      while(titem != stack){      while(titem != stack){
538        tstack=titem->next;        tstack=titem->next;
539        free(titem);        free(titem);
540        titem=tstack;        titem=tstack;
541      }      }
     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();  
 }  
542    
543  /* Prints the stack. */      if(! (env->err)){
544  extern void printstack(environment *env)        if(fprintf(stream, " ]") < 0){
545  {          perror("print_val");
546    if(env->head->type == empty) {          env->err= 5;
547      printf("Stack Empty\n");        }
548      return;      }
549        break;
550    }    }
   
   print_st(env->head, 1);  
551  }  }
552    
553  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
# Line 663  extern void swap(environment *env) Line 566  extern void swap(environment *env)
566    CDR(env->head)= temp;    CDR(env->head)= temp;
567  }  }
568    
 /* 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;  
 }  
   
569  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
570  extern void rcl(environment *env)  extern void rcl(environment *env)
571  {  {
# Line 710  extern void rcl(environment *env) Line 596  extern void rcl(environment *env)
596    if(env->err) return;    if(env->err) return;
597  }  }
598    
599    
600  /* 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
601     function value, and if it is, toss the symbol and execute the     function value, and if it is, toss the symbol and execute the
602     function. */     function. */
# Line 741  extern void eval(environment *env) Line 628  extern void eval(environment *env)
628    
629      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
630    case func:    case func:
631      in_func= (funcp)(CAR(env->head)->content.ptr);      in_func= CAR(env->head)->content.func;
632      toss(env);      toss(env);
633      if(env->err) return;      if(env->err) return;
634      return in_func(env);      return in_func(env);
# Line 780  extern void eval(environment *env) Line 667  extern void eval(environment *env)
667      return;      return;
668    
669    case empty:    case empty:
670        toss(env);
671    case integer:    case integer:
672    case tfloat:    case tfloat:
673    case string:    case string:
674      case port:
675      return;      return;
676    }    }
677  }  }
678    
679  /* Reverse (flip) a list */  /* List all defined words */
680  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)  
681  {  {
682    value *temp, *new_head;    symbol *temp;
683      int i;
684    /* Is top element a list? */    
685    if(env->head->type==empty) {    for(i= 0; i<HASHTBLSIZE; i++) {
686      printerr("Too Few Arguments");      temp= env->symbols[i];
687      env->err= 1;      while(temp!=NULL) {
688      return;  #ifdef DEBUG
689    }        if (temp->val != NULL && temp->val->gc.flag.protect)
690            printf("(protected) ");
691    if(CAR(env->head)->type!=tcons) {  #endif /* DEBUG */
692      printerr("Bad Argument Type");        printf("%s ", temp->id);
693      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;  
694      }      }
695    }    }
   
   /* Connect the tail of the list with the old stack head */  
   CDR(temp)= env->head;  
   env->head= new_head;          /* ...and voila! */  
   
696  }  }
697    
 /* 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);  
 }  
   
698  /* Quit stack. */  /* Quit stack. */
699  extern void quit(environment *env)  extern void quit(environment *env)
700  {  {
701    int i;    int i;
702    
703    clear(env);    while(env->head->type != empty)
704        toss(env);
705    
706    if (env->err) return;    if (env->err) return;
707    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
# Line 1003  extern void quit(environment *env) Line 726  extern void quit(environment *env)
726    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
727  }  }
728    
 /* 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;  
     }  
   }  
 }  
   
729  /* Internal forget function */  /* Internal forget function */
730  void forget_sym(symbol **hash_entry)  void forget_sym(symbol **hash_entry)
731  {  {
# Line 1041  void forget_sym(symbol **hash_entry) Line 738  void forget_sym(symbol **hash_entry)
738    free(temp);    free(temp);
739  }  }
740    
741  /* Forgets a symbol (remove it from the hash table) */  /* Only to be called by itself function printstack. */
742  extern void forget(environment *env)  void print_st(environment *env, value *stack_head, long counter)
743  {  {
744    char* sym_id;    if(CDR(stack_head)->type != empty)
745        print_st(env, CDR(stack_head), counter+1);
746      printf("%ld: ", counter);
747      print_val(env, CAR(stack_head), 0, NULL, stdout);
748      printf("\n");
749    }
750    
751    if(env->head->type==empty) {  /* Prints the stack. */
752      printerr("Too Few Arguments");  extern void printstack(environment *env)
753      env->err= 1;  {
754      return;    if(env->head->type == empty) {
755    }      printf("Stack Empty\n");
     
   if(CAR(env->head)->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
756      return;      return;
757    }    }
758    
759    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);  
760  }  }
761    
762  int main(int argc, char **argv)  int main(int argc, char **argv)
# Line 1121  under certain conditions; type 'copying; Line 810  under certain conditions; type 'copying;
810        if (myenv.interactive) {        if (myenv.interactive) {
811          if(myenv.err) {          if(myenv.err) {
812            printf("(error %d)\n", myenv.err);            printf("(error %d)\n", myenv.err);
813              myenv.err= 0;
814          }          }
815          nl();          printf("\n");
816          printstack(&myenv);          printstack(&myenv);
817          printf("> ");          printf("> ");
818        }        }
819        myenv.err=0;        myenv.err=0;
820      }      }
821      sx_72656164(&myenv);        /* "read" */      readstream(&myenv, myenv.inputstream);
822      if (myenv.err==4) {         /* EOF */      if (myenv.err) {            /* EOF or other error */
823        myenv.err=0;        myenv.err=0;
824        quit(&myenv);        quit(&myenv);
825      } else if(myenv.head->type!=empty      } else if(myenv.head->type!=empty
826                && CAR(myenv.head)->type==symb                && CAR(myenv.head)->type==symb
827                && CAR(myenv.head)->content.sym->id[0]                && CAR(myenv.head)->content.sym->id[0] == ';') {
828                ==';') {        toss(&myenv); if(myenv.err) continue;
       toss(&myenv);             /* No error check in main */  
829        eval(&myenv);        eval(&myenv);
830        } else {
831          gc_maybe(&myenv);
832      }      }
     gc_maybe(&myenv);  
833    }    }
834    quit(&myenv);    quit(&myenv);
835    return EXIT_FAILURE;    return EXIT_FAILURE;
836  }  }
837    
 /* "+" */  
 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);  
 }  
   
838  /* Return copy of a value */  /* Return copy of a value */
839  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
840  {  {
# Line 1376  value *copy_val(environment *env, value Line 843  value *copy_val(environment *env, value
843    if(old_value==NULL)    if(old_value==NULL)
844      return NULL;      return NULL;
845    
   protect(old_value);  
846    new_value= new_val(env);    new_value= new_val(env);
847    new_value->type= old_value->type;    new_value->type= old_value->type;
848    
# Line 1386  value *copy_val(environment *env, value Line 852  value *copy_val(environment *env, value
852    case func:    case func:
853    case symb:    case symb:
854    case empty:    case empty:
855      case port:
856      new_value->content= old_value->content;      new_value->content= old_value->content;
857      break;      break;
858    case string:    case string:
859      (char *)(new_value->content.ptr)=      new_value->content.string= strdup(old_value->content.string);
       strdup((char *)(old_value->content.ptr));  
860      break;      break;
861    case tcons:    case tcons:
862    
# Line 1403  value *copy_val(environment *env, value Line 869  value *copy_val(environment *env, value
869      break;      break;
870    }    }
871    
   unprotect(old_value);  
   
872    return new_value;    return new_value;
873  }  }
874    
875  /* "dup"; duplicates an item on the stack */  /* read a line from a stream; used by readline */
876  extern void sx_647570(environment *env)  void readlinestream(environment *env, FILE *stream)
877  {  {
878    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;  
   }  
879    
880    loop= CAR(env->head);    if(fgets(in_string, 100, stream)==NULL) {
881    protect(loop);      push_cstring(env, "");
882    toss(env); if(env->err) return;      if (! feof(stream)){
883          perror("readline");
884    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);  
885      }      }
886        } else {
887    } while(truth);      push_cstring(env, in_string);
888      }
   unprotect(loop); unprotect(test);  
889  }  }
890    
891    /* Reverse (flip) a list */
892  /* "for"; for-loop */  extern void rev(environment *env)
 extern void sx_666f72(environment *env)  
893  {  {
894    value *loop;    value *old_head, *new_head, *item;
   int foo1, foo2;  
895    
896    if(env->head->type==empty || CDR(env->head)->type==empty    if(env->head->type==empty) {
      || CDR(CDR(env->head))->type==empty) {  
897      printerr("Too Few Arguments");      printerr("Too Few Arguments");
898      env->err= 1;      env->err= 1;
899      return;      return;
900    }    }
901    
902    if(CAR(CDR(env->head))->type!=integer    if(CAR(env->head)->type==empty)
903       || 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;  
   }  
904    
905    if(CAR(CDR(env->head))->type!=tcons) {    if(CAR(env->head)->type!=tcons) {
906      printerr("Bad Argument Type");      printerr("Bad Argument Type");
907      env->err= 2;      env->err= 2;
908      return;      return;
909    }    }
910    
911    loop= CAR(env->head);    old_head= CAR(env->head);
912    protect(loop);    new_head= new_val(env);
913    toss(env); if(env->err) return;    while(old_head->type != empty) {
914        item= old_head;
915    foo= CAR(env->head);      old_head= CDR(old_head);
916    protect(foo);      CDR(item)= new_head;
917    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;  
     }  
918    }    }
919    unprotect(loop); unprotect(foo);    CAR(env->head)= new_head;
920  }  }
921    
922  /* "to" */  /* Make a list. */
923  extern void to(environment *env)  extern void pack(environment *env)
924  {  {
925    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;  
   }  
926    
927    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);  
   }  
928    
929    iterator= env->head;    iterator= env->head;
930      if(iterator->type == empty
   if(iterator->type==empty  
931       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
932           && CAR(iterator)->content.sym->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
933      temp= NULL;      temp= ending;
934      toss(env);      toss(env);
935    } else {    } else {
936      /* Search for first delimiter */      /* Search for first delimiter */
937      while(CDR(iterator)!=NULL      while(CDR(iterator)->type != empty
938            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
939                || CAR(CDR(iterator))->content.sym->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
940        iterator= CDR(iterator);        iterator= CDR(iterator);
941            
942      /* Extract list */      /* Extract list */
943      temp= env->head;      temp= env->head;
944      env->head= CDR(iterator);      env->head= CDR(iterator);
945      CDR(iterator)= NULL;      CDR(iterator)= ending;
946    
947      if(env->head!=NULL)      if(env->head->type != empty)
948        toss(env);        toss(env);
949    }    }
950    
951    /* Push list */    /* Push list */
   push_val(env, temp);  
 }  
952    
953  /* Read a string */    push_val(env, temp);
954  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);  
955  }  }
956    
957  /* "read"; Read a value and place on stack */  /* read from a stream; used by "read" and "readport" */
958  extern void sx_72656164(environment *env)  void readstream(environment *env, FILE *stream)
959  {  {
960    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
961    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
# Line 1761  extern void sx_72656164(environment *env Line 977  extern void sx_72656164(environment *env
977      if(depth > 0 && env->interactive) {      if(depth > 0 && env->interactive) {
978        printf("]> ");        printf("]> ");
979      }      }
980      readline(env); if(env->err) return;      readlinestream(env, env->inputstream);
981        if(env->err) return;
982    
983      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){      if((CAR(env->head)->content.string)[0]=='\0'){
984        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
985        return;        return;
986      }      }
987            
988      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.string)+1);
989      assert(env->in_string != NULL);      assert(env->in_string != NULL);
990      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
991      strcpy(env->in_string, CAR(env->head)->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.string);
992      toss(env); if(env->err) return;      toss(env); if(env->err) return;
993    }    }
994        
# Line 1821  extern void sx_72656164(environment *env Line 1038  extern void sx_72656164(environment *env
1038    free(match);    free(match);
1039    
1040    if(depth)    if(depth)
1041      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);  
1042  }  }
1043    
1044  extern void copying(environment *env)  extern void copying(environment *env)
# Line 2177  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER Line 1326  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER
1326  POSSIBILITY OF SUCH DAMAGES.\n");  POSSIBILITY OF SUCH DAMAGES.\n");
1327  }  }
1328    
1329  /* "*" */  /* Discard the top element of the stack. */
1330  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)  
1331  {  {
1332    if(env->head->type==empty) {    if(env->head->type==empty) {
1333      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1334      env->err= 1;      env->err= 1;
1335      return;      return;
1336    }    }
1337      
1338    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));  
1339  }  }
1340    
 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;  
 }  
Legend:
Removed from v.1.118  
changed lines
  Added in v.1.131
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26