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

Diff of /stack/stack.c

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

revision 1.110 by teddy, Sat Mar 16 09:12:39 2002 UTC revision 1.127 by masse, Mon Aug 4 11:57:33 2003 UTC
# Line 1  Line 1 
1    /* -*- coding: utf-8; -*- */
2  /*  /*
3      stack - an interactive interpreter for a stack-based language      stack - an interactive interpreter for a stack-based language
4      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn
# Line 20  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 60  void init_env(environment *env) Line 32  void init_env(environment *env)
32    env->gc_count= 0;    env->gc_count= 0;
33    env->gc_ref= NULL;    env->gc_ref= NULL;
34    
35    env->head= NULL;    env->head= new_val(env);
36    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
37      env->symbols[i]= NULL;      env->symbols[i]= NULL;
38    env->err= 0;    env->err= 0;
# Line 75  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==NULL) {  
     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 122  value* new_val(environment *env) Line 82  value* new_val(environment *env)
82    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
83    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
84    
85      assert(nval != NULL);
86      assert(nitem != NULL);
87    
88    nval->content.ptr= NULL;    nval->content.ptr= NULL;
89    nval->type= integer;    nval->type= empty;
90    
91    nitem->item= nval;    nitem->item= nval;
92    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
# Line 137  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 152  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)
122  {  {
123    stackitem *new_head= NULL, *titem;    stackitem *new_head= NULL, *titem;
   cons *iterator;  
124    symbol *tsymb;    symbol *tsymb;
125    int i;    int i;
126    
# Line 194  extern void gc_init(environment *env) Line 150  extern void gc_init(environment *env)
150    
151      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
152    
153        if(env->gc_ref->item->type==string) /* Remove content */        /* Remove content */
154          switch(env->gc_ref->item->type){
155          case string:
156          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
157            break;
158          case tcons:
159            free(env->gc_ref->item->content.c);
160            break;
161          case port:
162          case empty:
163          case integer:
164          case tfloat:
165          case func:
166          case symb:
167            /* 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 */
172        titem= env->gc_ref->next;        titem= env->gc_ref->next;
# Line 220  extern void gc_init(environment *env) Line 191  extern void gc_init(environment *env)
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 232  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);        env->gc_count += strlen(env->gc_ref->item->content.ptr)+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 251  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 284  void push_val(environment *env, value *v Line 263  void push_val(environment *env, value *v
263  {  {
264    value *new_value= new_val(env);    value *new_value= new_val(env);
265    
266    new_value->content.c= malloc(sizeof(cons));    new_value->content.c= malloc(sizeof(pair));
267    assert(new_value->content.c!=NULL);    assert(new_value->content.c!=NULL);
268      env->gc_count += sizeof(pair);
269    new_value->type= tcons;    new_value->type= tcons;
270    CAR(new_value)= val;    CAR(new_value)= val;
271    CDR(new_value)= env->head;    CDR(new_value)= env->head;
# Line 321  void push_cstring(environment *env, cons Line 301  void push_cstring(environment *env, cons
301    int length= strlen(in_string)+1;    int length= strlen(in_string)+1;
302    
303    new_value->content.ptr= malloc(length);    new_value->content.ptr= malloc(length);
304      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.ptr, in_string);
307    new_value->type= string;    new_value->type= string;
# Line 335  char *mangle_str(const char *old_string) Line 316  char *mangle_str(const char *old_string)
316    char *new_string, *current;    char *new_string, *current;
317    
318    new_string= malloc((strlen(old_string)*2)+4);    new_string= malloc((strlen(old_string)*2)+4);
319      assert(new_string != NULL);
320    strcpy(new_string, "sx_");    /* Stack eXternal */    strcpy(new_string, "sx_");    /* Stack eXternal */
321    current= new_string+3;    current= new_string+3;
322    while(old_string[0] != '\0'){    while(old_string[0] != '\0'){
# Line 352  extern void mangle(environment *env) Line 334  extern void mangle(environment *env)
334  {  {
335    char *new_string;    char *new_string;
336    
337    if(env->head==NULL) {    if(env->head->type==empty) {
338      printerr("Too Few Arguments");      printerr("Too Few Arguments");
339      env->err= 1;      env->err= 1;
340      return;      return;
# Line 404  void push_sym(environment *env, const ch Line 386  void push_sym(environment *env, const ch
386    
387      /* Create a new symbol */      /* Create a new symbol */
388      (*new_symbol)= malloc(sizeof(symbol));      (*new_symbol)= malloc(sizeof(symbol));
389        assert((*new_symbol) != NULL);
390      (*new_symbol)->val= NULL;   /* undefined value */      (*new_symbol)->val= NULL;   /* undefined value */
391      (*new_symbol)->next= NULL;      (*new_symbol)->next= NULL;
392      (*new_symbol)->id= malloc(strlen(in_string)+1);      (*new_symbol)->id= malloc(strlen(in_string)+1);
393        assert((*new_symbol)->id != NULL);
394      strcpy((*new_symbol)->id, in_string);      strcpy((*new_symbol)->id, in_string);
395    
396      /* Intern the new symbol in the hash table */      /* Intern the new symbol in the hash table */
# Line 440  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    
427  /* Print newline. */  /* Print a value */
428  extern void nl()  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
429  {  {
430    printf("\n");    stackitem *titem, *tstack;
431  }    int depth;
   
 /* Gets the type of a value */  
 extern void type(environment *env)  
 {  
   int typenum;  
432    
433    if(env->head==NULL) {    switch(val->type) {
434      printerr("Too Few Arguments");    case empty:
435      env->err= 1;      if(fprintf(stream, "[]") < 0){
436      return;        perror("print_val");
437    }        env->err= 5;
438          return;
439    typenum= CAR(env->head)->type;      }
   toss(env);  
   switch(typenum){  
   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, "list");  
440      break;      break;
   }  
 }      
   
 /* Prints the top element of the stack. */  
 void print_h(value *stack_head, int noquote)  
 {  
   switch(CAR(stack_head)->type) {  
441    case integer:    case integer:
442      printf("%d", CAR(stack_head)->content.i);      if(fprintf(stream, "%d", val->content.i) < 0){
443          perror("print_val");
444          env->err= 5;
445          return;
446        }
447      break;      break;
448    case tfloat:    case tfloat:
449      printf("%f", CAR(stack_head)->content.f);      if(fprintf(stream, "%f", val->content.f) < 0){
450          perror("print_val");
451          env->err= 5;
452          return;
453        }
454      break;      break;
455    case string:    case string:
456      if(noquote)      if(noquote){
457        printf("%s", (char*)CAR(stack_head)->content.ptr);        if(fprintf(stream, "%s", (char*)(val->content.ptr)) < 0){
458      else          perror("print_val");
459        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);          env->err= 5;
460            return;
461          }
462        } else {                    /* quote */
463          if(fprintf(stream, "\"%s\"", (char*)(val->content.ptr)) < 0){
464            perror("print_val");
465            env->err= 5;
466            return;
467          }
468        }
469      break;      break;
470    case symb:    case symb:
471      printf("%s", CAR(stack_head)->content.sym->id);      if(fprintf(stream, "%s", val->content.sym->id) < 0){
472          perror("print_val");
473          env->err= 5;
474          return;
475        }
476      break;      break;
477    case func:    case func:
478      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));      if(fprintf(stream, "#<function %p>", (funcp)(val->content.ptr)) < 0){
479          perror("print_val");
480          env->err= 5;
481          return;
482        }
483      break;      break;
484    case tcons:    case port:
485      /* A list is just a stack, so make stack_head point to it */      if(fprintf(stream, "#<port %p>", (funcp)(val->content.p)) < 0){
486      stack_head= CAR(stack_head);        perror("print_val");
487      printf("[ ");        env->err= 5;
488      while(stack_head != NULL) {        return;
       print_h(stack_head, noquote);  
       printf(" ");  
       stack_head= CDR(stack_head);  
489      }      }
     printf("]");  
490      break;      break;
491    }    case tcons:
492  }      if(fprintf(stream, "[ ") < 0){
493          perror("print_val");
494  extern void print_(environment *env)        env->err= 5;
495  {        return;
496    if(env->head==NULL) {      }
497      printerr("Too Few Arguments");      tstack= stack;
498      env->err= 1;      do {
499      return;        titem=malloc(sizeof(stackitem));
500    }        assert(titem != NULL);
501    print_h(env->head, 0);        titem->item=val;
502    nl();        titem->next=tstack;
503  }        tstack=titem;             /* Put it on the stack */
504          /* Search a stack of values being printed to see if we are already
505  /* Prints the top element of the stack and then discards it. */           printing this value */
506  extern void print(environment *env)        titem=tstack;
507  {        depth=0;
508    print_(env);        while(titem != NULL && titem->item != CAR(val)){
509    if(env->err) return;          titem=titem->next;
510    toss(env);          depth++;
511  }        }
512          if(titem != NULL){        /* If we found it on the stack, */
513  extern void princ_(environment *env)          if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
514  {            perror("print_val");
515    if(env->head==NULL) {            env->err= 5;
516      printerr("Too Few Arguments");            free(titem);
517      env->err= 1;            return;
518      return;          }
519    }        } else {
520    print_h(env->head, 1);          print_val(env, CAR(val), noquote, tstack, stream);
521  }        }
522          val= CDR(val);
523          switch(val->type){
524          case empty:
525            break;
526          case tcons:
527            /* Search a stack of values being printed to see if we are already
528               printing this value */
529            titem=tstack;
530            depth=0;
531            while(titem != NULL && titem->item != val){
532              titem=titem->next;
533              depth++;
534            }
535            if(titem != NULL){      /* If we found it on the stack, */
536              if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
537                perror("print_val");
538                env->err= 5;
539                goto printval_end;
540              }
541            } else {
542              if(fprintf(stream, " ") < 0){
543                perror("print_val");
544                env->err= 5;
545                goto printval_end;
546              }
547            }
548            break;
549          default:
550            if(fprintf(stream, " . ") < 0){ /* Improper list */
551              perror("print_val");
552              env->err= 5;
553              goto printval_end;
554            }
555            print_val(env, val, noquote, tstack, stream);
556          }
557        } while(val->type == tcons && titem == NULL);
558    
559  /* Prints the top element of the stack and then discards it. */    printval_end:
 extern void princ(environment *env)  
 {  
   princ_(env);  
   if(env->err) return;  
   toss(env);  
 }  
560    
561  /* Only to be called by function printstack. */      titem=tstack;
562  void print_st(value *stack_head, long counter)      while(titem != stack){
563  {        tstack=titem->next;
564    if(CDR(stack_head) != NULL)        free(titem);
565      print_st(CDR(stack_head), counter+1);        titem=tstack;
566    printf("%ld: ", counter);      }
   print_h(stack_head, 0);  
   nl();  
 }  
567    
568  /* Prints the stack. */      if(! (env->err)){
569  extern void printstack(environment *env)        if(fprintf(stream, " ]") < 0){
570  {          perror("print_val");
571    if(env->head == NULL) {          env->err= 5;
572      printf("Stack Empty\n");        }
573      return;      }
574        break;
575    }    }
   
   print_st(env->head, 1);  
576  }  }
577    
578  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
# Line 580  extern void swap(environment *env) Line 580  extern void swap(environment *env)
580  {  {
581    value *temp= env->head;    value *temp= env->head;
582        
583    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
584      printerr("Too Few Arguments");      printerr("Too Few Arguments");
585      env->err=1;      env->err=1;
586      return;      return;
# Line 591  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==NULL || CDR(env->head)==NULL  
      || CDR(CDR(env->head))==NULL) {  
     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  {  {
597    value *val;    value *val;
598    
599    if(env->head==NULL) {    if(env->head->type==empty) {
600      printerr("Too Few Arguments");      printerr("Too Few Arguments");
601      env->err= 1;      env->err= 1;
602      return;      return;
# Line 638  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 651  extern void eval(environment *env) Line 635  extern void eval(environment *env)
635    
636    gc_maybe(env);    gc_maybe(env);
637    
638    if(env->head==NULL) {    if(env->head->type==empty) {
639      printerr("Too Few Arguments");      printerr("Too Few Arguments");
640      env->err= 1;      env->err= 1;
641      return;      return;
# Line 682  extern void eval(environment *env) Line 666  extern void eval(environment *env)
666      toss(env); if(env->err) return;      toss(env); if(env->err) return;
667      iterator= temp_val;      iterator= temp_val;
668            
669      while(iterator!=NULL) {      while(iterator->type != empty) {
670        push_val(env, CAR(iterator));        push_val(env, CAR(iterator));
671                
672        if(CAR(env->head)->type==symb        if(CAR(env->head)->type==symb
# Line 690  extern void eval(environment *env) Line 674  extern void eval(environment *env)
674          toss(env);          toss(env);
675          if(env->err) return;          if(env->err) return;
676                    
677          if(CDR(iterator)==NULL){          if(CDR(iterator)->type == empty){
678            goto eval_start;            goto eval_start;
679          }          }
680          eval(env);          eval(env);
681          if(env->err) return;          if(env->err) return;
682        }        }
683        if (CDR(iterator)==NULL || CDR(iterator)->type == tcons)        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
684          iterator= CDR(iterator);          iterator= CDR(iterator);
685        else {        else {
686          printerr("Bad Argument Type"); /* Improper list */          printerr("Bad Argument Type"); /* Improper list */
# Line 707  extern void eval(environment *env) Line 691  extern void eval(environment *env)
691      unprotect(temp_val);      unprotect(temp_val);
692      return;      return;
693    
694    default:    case empty:
695      return;      toss(env);
696    }    case integer:
697  }    case tfloat:
698      case string:
699  /* Reverse (flip) a list */    case port:
 extern void rev(environment *env)  
 {  
   value *old_head, *new_head, *item;  
   
   if(env->head==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=tcons) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
700      return;      return;
701    }    }
   
   old_head= CAR(env->head);  
   new_head= NULL;  
   while(old_head!=NULL) {  
     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;  
   
   iterator= env->head;  
   if(iterator==NULL  
      || (CAR(iterator)->type==symb  
      && CAR(iterator)->content.sym->id[0]=='[')) {  
     temp= NULL;  
     toss(env);  
   } else {  
     /* Search for first delimiter */  
     while(CDR(iterator)!=NULL  
           && (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)= NULL;  
   
     if(env->head!=NULL)  
       toss(env);  
   }  
   
   /* Push list */  
   
   push_val(env, temp);  
   rev(env);  
702  }  }
703    
704  /* Relocate elements of the list on the stack. */  /* List all defined words */
705  extern void expand(environment *env)  extern void words(environment *env)
706  {  {
707    value *temp, *new_head;    symbol *temp;
708      int i;
709    /* Is top element a list? */    
710    if(env->head==NULL) {    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)->content.ptr != NULL) {  
     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! */  
   
 }  
   
 /* Compares two elements by reference. */  
 extern void eq(environment *env)  
 {  
   void *left, *right;  
   
   if(env->head==NULL || CDR(env->head)==NULL) {  
     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==NULL) {  
     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);  
721  }  }
722    
 /* 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==NULL || CDR(env->head)==NULL) {  
     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 923  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!=NULL)  
     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 961  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    value *stack_head= env->head;      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(stack_head==NULL) {  /* 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(stack_head)->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
781      return;      return;
782    }    }
783    
784    sym_id= CAR(stack_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 1042  under certain conditions; type 'copying; Line 835  under certain conditions; type 'copying;
835        if (myenv.interactive) {        if (myenv.interactive) {
836          if(myenv.err) {          if(myenv.err) {
837            printf("(error %d)\n", myenv.err);            printf("(error %d)\n", myenv.err);
838              myenv.err= 0;
839          }          }
840          nl();          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==4) {         /* EOF */      if (myenv.err) {            /* EOF or other error */
848        myenv.err=0;        myenv.err=0;
849        quit(&myenv);        quit(&myenv);
850      } else if(myenv.head!=NULL      } else if(myenv.head->type!=empty
851                && CAR(myenv.head)->type==symb                && CAR(myenv.head)->type==symb
852                && CAR(myenv.head)->content.sym->id[0]                && CAR(myenv.head)->content.sym->id[0] == ';') {
853                ==';') {        toss(&myenv); if(myenv.err) continue;
       toss(&myenv);             /* No error check in main */  
854        eval(&myenv);        eval(&myenv);
855        } else {
856          gc_maybe(&myenv);
857      }      }
     gc_maybe(&myenv);  
858    }    }
859    quit(&myenv);    quit(&myenv);
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==NULL || CDR(env->head)==NULL) {  
     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);  
     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==NULL || CDR(env->head)==NULL) {  
     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==NULL || CDR(env->head)==NULL) {  
     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 1296  value *copy_val(environment *env, value Line 868  value *copy_val(environment *env, value
868    if(old_value==NULL)    if(old_value==NULL)
869      return NULL;      return NULL;
870    
   protect(old_value);  
871    new_value= new_val(env);    new_value= new_val(env);
872    new_value->type= old_value->type;    new_value->type= old_value->type;
873    
# Line 1305  value *copy_val(environment *env, value Line 876  value *copy_val(environment *env, value
876    case integer:    case integer:
877    case func:    case func:
878    case symb:    case symb:
879      case empty:
880      case port:
881      new_value->content= old_value->content;      new_value->content= old_value->content;
882      break;      break;
883    case string:    case string:
# Line 1313  value *copy_val(environment *env, value Line 886  value *copy_val(environment *env, value
886      break;      break;
887    case tcons:    case tcons:
888    
889      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(pair));
890      assert(new_value->content.c!=NULL);      assert(new_value->content.c!=NULL);
891        env->gc_count += sizeof(pair);
892    
893      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
894      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
895      break;      break;
896    }    }
897    
   unprotect(old_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==NULL) {  
     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==NULL || CDR(env->head)==NULL) {  
     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==NULL || CDR(env->head)==NULL  
      || CDR(CDR(env->head))==NULL) {  
     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==NULL || CDR(env->head)==NULL  
      || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL  
      || CDR(CDR(CDR(CDR(env->head))))==NULL) {  
     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==NULL || CDR(env->head)==NULL  
      || CDR(CDR(env->head))==NULL) {  
     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==NULL || CDR(env->head)==NULL) {  
     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==NULL || CDR(env->head)==NULL    if(env->head->type==empty) {
      || CDR(CDR(env->head))==NULL) {  
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);  
 }  
930    
931  /* Variant of for-loop */    if(CAR(env->head)->type!=tcons) {
 extern void foreach(environment *env)  
 {    
   value *loop, *foo;  
   value *iterator;  
     
   if(env->head==NULL || CDR(env->head)==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(CDR(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!=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;  
     }  
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;  
   
   if(env->head==NULL || CDR(env->head)==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
952    
953    if(CAR(env->head)->type!=integer    ending=new_val(env);
      || 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, "[");  
   
   if(ending>=start) {  
     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==NULL  
957       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
958           && CAR(iterator)->content.sym->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
959      temp= NULL;      temp= ending;
960      toss(env);      toss(env);
961    } else {    } else {
962      /* Search for first delimiter */      /* Search for first delimiter */
963      while(CDR(iterator)!=NULL      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)= NULL;      CDR(iterator)= ending;
972    
973      if(env->head!=NULL)      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)  
 {  
   char in_string[101];  
978    
979    if(fgets(in_string, 100, env->inputstream)==NULL)    push_val(env, temp);
980      push_cstring(env, "");    rev(env);
   else  
     push_cstring(env, in_string);  
981  }  }
982    
983  /* "read"; Read a value and place on stack */  /* read from a stream; used by "read" and "readport" */
984  extern void sx_72656164(environment *env)  void readstream(environment *env, FILE *stream)
985  {  {
986    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
987    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
# Line 1672  extern void sx_72656164(environment *env Line 996  extern void sx_72656164(environment *env
996    int count= -1;    int count= -1;
997    float ftemp;    float ftemp;
998    static int depth= 0;    static int depth= 0;
999    char *match, *ctemp;    char *match;
1000    size_t inlength;    size_t inlength;
1001    
1002    if(env->in_string==NULL) {    if(env->in_string==NULL) {
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 1687  extern void sx_72656164(environment *env Line 1012  extern void sx_72656164(environment *env
1012      }      }
1013            
1014      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1015        assert(env->in_string != NULL);
1016      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1017      strcpy(env->in_string, CAR(env->head)->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1018      toss(env); if(env->err) return;      toss(env); if(env->err) return;
# Line 1694  extern void sx_72656164(environment *env Line 1020  extern void sx_72656164(environment *env
1020        
1021    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1022    match= malloc(inlength);    match= malloc(inlength);
1023      assert(match != NULL);
1024    
1025    if(sscanf(env->in_string, blankform, &readlength) != EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1026       && readlength != -1) {       && readlength != -1) {
# Line 1706  extern void sx_72656164(environment *env Line 1033  extern void sx_72656164(environment *env
1033      } else {      } else {
1034        push_float(env, ftemp);        push_float(env, ftemp);
1035      }      }
1036      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1037                && readlength != -1) {
1038        push_cstring(env, "");
1039    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1040              && readlength != -1) {              && readlength != -1) {
1041      push_cstring(env, match);      push_cstring(env, match);
# Line 1734  extern void sx_72656164(environment *env Line 1064  extern void sx_72656164(environment *env
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==NULL || CDR(env->head)==NULL) {  
     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==NULL) {  
     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)
1071  {  {
1072    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
1073                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1074  \n\  \n\
1075   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 2090  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    
1355  /* "*" */  /* General assoc function */
1356  extern void sx_2a(environment *env)  void assocgen(environment *env, funcp eqfunc)
1357  {  {
1358    int a, b;    value *key, *item;
   float fa, fb;  
1359    
1360    if(env->head==NULL || CDR(env->head)==NULL) {    /* Needs two values on the stack, the top one must be an association
1361         list */
1362      if(env->head->type==empty || CDR(env->head)->type==empty) {
1363      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1364      env->err= 1;      env->err= 1;
1365      return;      return;
1366    }    }
     
   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;  
   }  
1367    
1368    if(CAR(env->head)->type==tfloat    if(CAR(env->head)->type!=tcons) {
1369       && CAR(CDR(env->head))->type==tfloat) {      printerr("Bad Argument Type");
1370      fa= CAR(env->head)->content.f;      env->err= 2;
     toss(env); if(env->err) return;  
     fb= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb*fa);  
       
1371      return;      return;
1372    }    }
1373    
1374    if(CAR(env->head)->type==tfloat    key=CAR(CDR(env->head));
1375       && CAR(CDR(env->head))->type==integer) {    item=CAR(env->head);
     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;  
   }  
1376    
1377    if(CAR(env->head)->type==integer    while(item->type == tcons){
1378       && CAR(CDR(env->head))->type==tfloat) {      if(CAR(item)->type != tcons){
1379      a= CAR(env->head)->content.i;        printerr("Bad Argument Type");
1380      toss(env); if(env->err) return;        env->err= 2;
1381      fb= CAR(env->head)->content.f;        return;
1382      toss(env); if(env->err) return;      }
1383      push_float(env, fb*a);      push_val(env, key);
1384        push_val(env, CAR(CAR(item)));
1385        eqfunc(env); if(env->err) return;
1386    
1387        /* Check the result of 'eqfunc' */
1388        if(env->head->type==empty) {
1389          printerr("Too Few Arguments");
1390          env->err= 1;
1391      return;      return;
1392    }      }
1393        if(CAR(env->head)->type!=integer) {
1394    printerr("Bad Argument Type");        printerr("Bad Argument Type");
1395    env->err= 2;        env->err= 2;
1396  }        return;
1397        }
 /* "/" */  
 extern void sx_2f(environment *env)  
 {  
   int a, b;  
   float fa, fb;  
1398    
1399    if(env->head==NULL || CDR(env->head)==NULL) {      if(CAR(env->head)->content.i){
1400      printerr("Too Few Arguments");        toss(env); if(env->err) return;
1401      env->err= 1;        break;
1402      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;  
1403      toss(env); if(env->err) return;      toss(env); if(env->err) return;
     push_float(env, b/a);  
1404    
1405      return;      if(item->type!=tcons) {
1406    }        printerr("Bad Argument Type");
1407          env->err= 2;
1408    if(CAR(env->head)->type==tfloat        return;
1409       && 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;  
   }  
1410    
1411    if(CAR(env->head)->type==tfloat      item=CDR(item);
      && 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;  
1412    }    }
1413    
1414    if(CAR(env->head)->type==integer    if(item->type == tcons){      /* A match was found */
1415       && CAR(CDR(env->head))->type==tfloat) {      push_val(env, CAR(item));
1416      a= CAR(env->head)->content.i;    } else {
1417      toss(env); if(env->err) return;      push_int(env, 0);
     fb= CAR(env->head)->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb/a);  
   
     return;  
1418    }    }
1419      swap(env); if(env->err) return;
1420    printerr("Bad Argument Type");    toss(env); if(env->err) return;
1421    env->err= 2;    swap(env); if(env->err) return;
1422      toss(env);
1423  }  }
1424    
1425  /* "mod" */  /* Discard the top element of the stack. */
1426  extern void mod(environment *env)  extern void toss(environment *env)
1427  {  {
1428    int a, b;    if(env->head->type==empty) {
   
   if(env->head==NULL || CDR(env->head)==NULL) {  
1429      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1430      env->err= 1;      env->err= 1;
1431      return;      return;
1432    }    }
1433        
1434    if(CAR(env->head)->type==integer    env->head= CDR(env->head); /* Remove the top stack item */
      && 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;  
1435  }  }
1436    
 /* "div" */  
 extern void sx_646976(environment *env)  
 {  
   int a, b;  
     
   if(env->head==NULL || CDR(env->head)==NULL) {  
     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;  
 }  
Legend:
Removed from v.1.110  
changed lines
  Added in v.1.127
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26