/[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.128 by masse, Mon Aug 4 13:50:53 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 214  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 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.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 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 320  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);
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 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 364  extern void mangle(environment *env) Line 346  extern void mangle(environment *env)
346      return;      return;
347    }    }
348    
349    new_string=    new_string= mangle_str(CAR(env->head)->content.string);
     mangle_str((const char *)(CAR(env->head)->content.ptr));  
350    
351    toss(env);    toss(env);
352    if(env->err) return;    if(env->err) return;
# Line 404  void push_sym(environment *env, const ch Line 385  void push_sym(environment *env, const ch
385    
386      /* Create a new symbol */      /* Create a new symbol */
387      (*new_symbol)= malloc(sizeof(symbol));      (*new_symbol)= malloc(sizeof(symbol));
388        assert((*new_symbol) != NULL);
389      (*new_symbol)->val= NULL;   /* undefined value */      (*new_symbol)->val= NULL;   /* undefined value */
390      (*new_symbol)->next= NULL;      (*new_symbol)->next= NULL;
391      (*new_symbol)->id= malloc(strlen(in_string)+1);      (*new_symbol)->id= malloc(strlen(in_string)+1);
392        assert((*new_symbol)->id != NULL);
393      strcpy((*new_symbol)->id, in_string);      strcpy((*new_symbol)->id, in_string);
394    
395      /* Intern the new symbol in the hash table */      /* Intern the new symbol in the hash table */
# Line 428  void push_sym(environment *env, const ch Line 411  void push_sym(environment *env, const ch
411    
412      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
413        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
414        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.func= funcptr; /* Store function pointer */
415        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
416                                           function value */                                           function value */
417      }      }
# Line 440  void push_sym(environment *env, const ch Line 423  void push_sym(environment *env, const ch
423    unprotect(new_value); unprotect(new_fvalue);    unprotect(new_value); unprotect(new_fvalue);
424  }  }
425    
426  /* Print newline. */  /* Print a value */
427  extern void nl()  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
428  {  {
429    printf("\n");    stackitem *titem, *tstack;
430  }    int depth;
   
 /* Gets the type of a value */  
 extern void type(environment *env)  
 {  
   int typenum;  
431    
432    if(env->head==NULL) {    switch(val->type) {
433      printerr("Too Few Arguments");    case empty:
434      env->err= 1;      if(fprintf(stream, "[]") < 0){
435      return;        perror("print_val");
436    }        env->err= 5;
437          return;
438    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");  
439      break;      break;
   }  
 }      
   
 /* Prints the top element of the stack. */  
 void print_h(value *stack_head, int noquote)  
 {  
   switch(CAR(stack_head)->type) {  
440    case integer:    case integer:
441      printf("%d", CAR(stack_head)->content.i);      if(fprintf(stream, "%d", val->content.i) < 0){
442          perror("print_val");
443          env->err= 5;
444          return;
445        }
446      break;      break;
447    case tfloat:    case tfloat:
448      printf("%f", CAR(stack_head)->content.f);      if(fprintf(stream, "%f", val->content.f) < 0){
449          perror("print_val");
450          env->err= 5;
451          return;
452        }
453      break;      break;
454    case string:    case string:
455      if(noquote)      if(noquote){
456        printf("%s", (char*)CAR(stack_head)->content.ptr);        if(fprintf(stream, "%s", val->content.string) < 0){
457      else          perror("print_val");
458        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);          env->err= 5;
459            return;
460          }
461        } else {                    /* quote */
462          if(fprintf(stream, "\"%s\"", val->content.string) < 0){
463            perror("print_val");
464            env->err= 5;
465            return;
466          }
467        }
468      break;      break;
469    case symb:    case symb:
470      printf("%s", CAR(stack_head)->content.sym->id);      if(fprintf(stream, "%s", val->content.sym->id) < 0){
471          perror("print_val");
472          env->err= 5;
473          return;
474        }
475      break;      break;
476    case func:    case func:
477      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));      if(fprintf(stream, "#<function %p>", val->content.func) < 0){
478          perror("print_val");
479          env->err= 5;
480          return;
481        }
482      break;      break;
483    case tcons:    case port:
484      /* A list is just a stack, so make stack_head point to it */      if(fprintf(stream, "#<port %p>", val->content.p) < 0){
485      stack_head= CAR(stack_head);        perror("print_val");
486      printf("[ ");        env->err= 5;
487      while(stack_head != NULL) {        return;
       print_h(stack_head, noquote);  
       printf(" ");  
       stack_head= CDR(stack_head);  
488      }      }
     printf("]");  
489      break;      break;
490    }    case tcons:
491  }      if(fprintf(stream, "[ ") < 0){
492          perror("print_val");
493  extern void print_(environment *env)        env->err= 5;
494  {        return;
495    if(env->head==NULL) {      }
496      printerr("Too Few Arguments");      tstack= stack;
497      env->err= 1;      do {
498      return;        titem=malloc(sizeof(stackitem));
499    }        assert(titem != NULL);
500    print_h(env->head, 0);        titem->item=val;
501    nl();        titem->next=tstack;
502  }        tstack=titem;             /* Put it on the stack */
503          /* Search a stack of values being printed to see if we are already
504  /* Prints the top element of the stack and then discards it. */           printing this value */
505  extern void print(environment *env)        titem=tstack;
506  {        depth=0;
507    print_(env);        while(titem != NULL && titem->item != CAR(val)){
508    if(env->err) return;          titem=titem->next;
509    toss(env);          depth++;
510  }        }
511          if(titem != NULL){        /* If we found it on the stack, */
512  extern void princ_(environment *env)          if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
513  {            perror("print_val");
514    if(env->head==NULL) {            env->err= 5;
515      printerr("Too Few Arguments");            free(titem);
516      env->err= 1;            return;
517      return;          }
518    }        } else {
519    print_h(env->head, 1);          print_val(env, CAR(val), noquote, tstack, stream);
520  }        }
521          val= CDR(val);
522          switch(val->type){
523          case empty:
524            break;
525          case tcons:
526            /* Search a stack of values being printed to see if we are already
527               printing this value */
528            titem=tstack;
529            depth=0;
530            while(titem != NULL && titem->item != val){
531              titem=titem->next;
532              depth++;
533            }
534            if(titem != NULL){      /* If we found it on the stack, */
535              if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
536                perror("print_val");
537                env->err= 5;
538                goto printval_end;
539              }
540            } else {
541              if(fprintf(stream, " ") < 0){
542                perror("print_val");
543                env->err= 5;
544                goto printval_end;
545              }
546            }
547            break;
548          default:
549            if(fprintf(stream, " . ") < 0){ /* Improper list */
550              perror("print_val");
551              env->err= 5;
552              goto printval_end;
553            }
554            print_val(env, val, noquote, tstack, stream);
555          }
556        } while(val->type == tcons && titem == NULL);
557    
558  /* 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);  
 }  
559    
560  /* Only to be called by function printstack. */      titem=tstack;
561  void print_st(value *stack_head, long counter)      while(titem != stack){
562  {        tstack=titem->next;
563    if(CDR(stack_head) != NULL)        free(titem);
564      print_st(CDR(stack_head), counter+1);        titem=tstack;
565    printf("%ld: ", counter);      }
   print_h(stack_head, 0);  
   nl();  
 }  
566    
567  /* Prints the stack. */      if(! (env->err)){
568  extern void printstack(environment *env)        if(fprintf(stream, " ]") < 0){
569  {          perror("print_val");
570    if(env->head == NULL) {          env->err= 5;
571      printf("Stack Empty\n");        }
572      return;      }
573        break;
574    }    }
   
   print_st(env->head, 1);  
575  }  }
576    
577  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
# Line 580  extern void swap(environment *env) Line 579  extern void swap(environment *env)
579  {  {
580    value *temp= env->head;    value *temp= env->head;
581        
582    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
583      printerr("Too Few Arguments");      printerr("Too Few Arguments");
584      env->err=1;      env->err=1;
585      return;      return;
# Line 591  extern void swap(environment *env) Line 590  extern void swap(environment *env)
590    CDR(env->head)= temp;    CDR(env->head)= temp;
591  }  }
592    
 /* Rotate the first three elements on the stack. */  
 extern void rot(environment *env)  
 {  
   value *temp= env->head;  
     
   if(env->head==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;  
 }  
   
593  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
594  extern void rcl(environment *env)  extern void rcl(environment *env)
595  {  {
596    value *val;    value *val;
597    
598    if(env->head==NULL) {    if(env->head->type==empty) {
599      printerr("Too Few Arguments");      printerr("Too Few Arguments");
600      env->err= 1;      env->err= 1;
601      return;      return;
# Line 638  extern void rcl(environment *env) Line 620  extern void rcl(environment *env)
620    if(env->err) return;    if(env->err) return;
621  }  }
622    
623    
624  /* If the top element is a symbol, determine if it's bound to a  /* If the top element is a symbol, determine if it's bound to a
625     function value, and if it is, toss the symbol and execute the     function value, and if it is, toss the symbol and execute the
626     function. */     function. */
# Line 651  extern void eval(environment *env) Line 634  extern void eval(environment *env)
634    
635    gc_maybe(env);    gc_maybe(env);
636    
637    if(env->head==NULL) {    if(env->head->type==empty) {
638      printerr("Too Few Arguments");      printerr("Too Few Arguments");
639      env->err= 1;      env->err= 1;
640      return;      return;
# Line 669  extern void eval(environment *env) Line 652  extern void eval(environment *env)
652    
653      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
654    case func:    case func:
655      in_func= (funcp)(CAR(env->head)->content.ptr);      in_func= CAR(env->head)->content.func;
656      toss(env);      toss(env);
657      if(env->err) return;      if(env->err) return;
658      return in_func(env);      return in_func(env);
# Line 682  extern void eval(environment *env) Line 665  extern void eval(environment *env)
665      toss(env); if(env->err) return;      toss(env); if(env->err) return;
666      iterator= temp_val;      iterator= temp_val;
667            
668      while(iterator!=NULL) {      while(iterator->type != empty) {
669        push_val(env, CAR(iterator));        push_val(env, CAR(iterator));
670                
671        if(CAR(env->head)->type==symb        if(CAR(env->head)->type==symb
# Line 690  extern void eval(environment *env) Line 673  extern void eval(environment *env)
673          toss(env);          toss(env);
674          if(env->err) return;          if(env->err) return;
675                    
676          if(CDR(iterator)==NULL){          if(CDR(iterator)->type == empty){
677            goto eval_start;            goto eval_start;
678          }          }
679          eval(env);          eval(env);
680          if(env->err) return;          if(env->err) return;
681        }        }
682        if (CDR(iterator)==NULL || CDR(iterator)->type == tcons)        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
683          iterator= CDR(iterator);          iterator= CDR(iterator);
684        else {        else {
685          printerr("Bad Argument Type"); /* Improper list */          printerr("Bad Argument Type"); /* Improper list */
# Line 707  extern void eval(environment *env) Line 690  extern void eval(environment *env)
690      unprotect(temp_val);      unprotect(temp_val);
691      return;      return;
692    
693    default:    case empty:
694      return;      toss(env);
695    }    case integer:
696  }    case tfloat:
697      case string:
698  /* 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;  
699      return;      return;
700    }    }
   
   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);  
701  }  }
702    
703  /* Relocate elements of the list on the stack. */  /* List all defined words */
704  extern void expand(environment *env)  extern void words(environment *env)
705  {  {
706    value *temp, *new_head;    symbol *temp;
707      int i;
708    /* Is top element a list? */    
709    if(env->head==NULL) {    for(i= 0; i<HASHTBLSIZE; i++) {
710      printerr("Too Few Arguments");      temp= env->symbols[i];
711      env->err= 1;      while(temp!=NULL) {
712      return;  #ifdef DEBUG
713    }        if (temp->val != NULL && temp->val->gc.flag.protect)
714            printf("(protected) ");
715    if(CAR(env->head)->type!=tcons) {  #endif /* DEBUG */
716      printerr("Bad Argument Type");        printf("%s ", temp->id);
717      env->err= 2;        temp= temp->next;
     return;  
   }  
   
   rev(env);  
   
   if(env->err)  
     return;  
   
   /* The first list element is the new stack head */  
   new_head= temp= CAR(env->head);  
   
   toss(env);  
   
   /* Find the end of the list */  
   while(CDR(temp)->content.ptr != NULL) {  
     if (CDR(temp)->type == tcons)  
       temp= CDR(temp);  
     else {  
       printerr("Bad Argument Type"); /* Improper list */  
       env->err= 2;  
       return;  
718      }      }
719    }    }
   
   /* Connect the tail of the list with the old stack head */  
   CDR(temp)= env->head;  
   env->head= new_head;          /* ...and voila! */  
   
 }  
   
 /* 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);  
720  }  }
721    
 /* 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);  
 }  
   
722  /* Quit stack. */  /* Quit stack. */
723  extern void quit(environment *env)  extern void quit(environment *env)
724  {  {
725    int i;    int i;
726    
727    clear(env);    while(env->head->type != empty)
728        toss(env);
729    
730    if (env->err) return;    if (env->err) return;
731    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
# Line 923  extern void quit(environment *env) Line 750  extern void quit(environment *env)
750    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
751  }  }
752    
 /* Clear stack */  
 extern void clear(environment *env)  
 {  
   while(env->head!=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;  
     }  
   }  
 }  
   
753  /* Internal forget function */  /* Internal forget function */
754  void forget_sym(symbol **hash_entry)  void forget_sym(symbol **hash_entry)
755  {  {
# Line 961  void forget_sym(symbol **hash_entry) Line 762  void forget_sym(symbol **hash_entry)
762    free(temp);    free(temp);
763  }  }
764    
765  /* Forgets a symbol (remove it from the hash table) */  /* Only to be called by itself function printstack. */
766  extern void forget(environment *env)  void print_st(environment *env, value *stack_head, long counter)
767  {  {
768    char* sym_id;    if(CDR(stack_head)->type != empty)
769    value *stack_head= env->head;      print_st(env, CDR(stack_head), counter+1);
770      printf("%ld: ", counter);
771      print_val(env, CAR(stack_head), 0, NULL, stdout);
772      printf("\n");
773    }
774    
775    if(stack_head==NULL) {  /* Prints the stack. */
776      printerr("Too Few Arguments");  extern void printstack(environment *env)
777      env->err= 1;  {
778      return;    if(env->head->type == empty) {
779    }      printf("Stack Empty\n");
     
   if(CAR(stack_head)->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
780      return;      return;
781    }    }
782    
783    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);  
784  }  }
785    
786  int main(int argc, char **argv)  int main(int argc, char **argv)
# Line 1042  under certain conditions; type 'copying; Line 834  under certain conditions; type 'copying;
834        if (myenv.interactive) {        if (myenv.interactive) {
835          if(myenv.err) {          if(myenv.err) {
836            printf("(error %d)\n", myenv.err);            printf("(error %d)\n", myenv.err);
837              myenv.err= 0;
838          }          }
839          nl();          printf("\n");
840          printstack(&myenv);          printstack(&myenv);
841          printf("> ");          printf("> ");
842        }        }
843        myenv.err=0;        myenv.err=0;
844      }      }
845      sx_72656164(&myenv);        /* "read" */      readstream(&myenv, myenv.inputstream);
846      if (myenv.err==4) {         /* EOF */      if (myenv.err) {            /* EOF or other error */
847        myenv.err=0;        myenv.err=0;
848        quit(&myenv);        quit(&myenv);
849      } else if(myenv.head!=NULL      } else if(myenv.head->type!=empty
850                && CAR(myenv.head)->type==symb                && CAR(myenv.head)->type==symb
851                && CAR(myenv.head)->content.sym->id[0]                && CAR(myenv.head)->content.sym->id[0] == ';') {
852                ==';') {        toss(&myenv); if(myenv.err) continue;
       toss(&myenv);             /* No error check in main */  
853        eval(&myenv);        eval(&myenv);
854        } else {
855          gc_maybe(&myenv);
856      }      }
     gc_maybe(&myenv);  
857    }    }
858    quit(&myenv);    quit(&myenv);
859    return EXIT_FAILURE;    return EXIT_FAILURE;
860  }  }
861    
 /* "+" */  
 extern void sx_2b(environment *env)  
 {  
   int a, b;  
   float fa, fb;  
   size_t len;  
   char* new_string;  
   value *a_val, *b_val;  
   
   if(env->head==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);  
 }  
   
862  /* Return copy of a value */  /* Return copy of a value */
863  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
864  {  {
# Line 1296  value *copy_val(environment *env, value Line 867  value *copy_val(environment *env, value
867    if(old_value==NULL)    if(old_value==NULL)
868      return NULL;      return NULL;
869    
   protect(old_value);  
870    new_value= new_val(env);    new_value= new_val(env);
871    new_value->type= old_value->type;    new_value->type= old_value->type;
872    
# Line 1305  value *copy_val(environment *env, value Line 875  value *copy_val(environment *env, value
875    case integer:    case integer:
876    case func:    case func:
877    case symb:    case symb:
878      case empty:
879      case port:
880      new_value->content= old_value->content;      new_value->content= old_value->content;
881      break;      break;
882    case string:    case string:
883      (char *)(new_value->content.ptr)=      new_value->content.string= strdup(old_value->content.string);
       strdup((char *)(old_value->content.ptr));  
884      break;      break;
885    case tcons:    case tcons:
886    
887      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(pair));
888      assert(new_value->content.c!=NULL);      assert(new_value->content.c!=NULL);
889        env->gc_count += sizeof(pair);
890    
891      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
892      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
893      break;      break;
894    }    }
895    
   unprotect(old_value);  
   
896    return new_value;    return new_value;
897  }  }
898    
899  /* "dup"; duplicates an item on the stack */  /* read a line from a stream; used by readline */
900  extern void sx_647570(environment *env)  void readlinestream(environment *env, FILE *stream)
 {  
   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)  
901  {  {
902    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;  
903    
904    do {    if(fgets(in_string, 100, stream)==NULL) {
905      push_val(env, test);      push_cstring(env, "");
906      eval(env);      if (! feof(stream)){
907              perror("readline");
908      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);  
909      }      }
910        } else {
911    } while(truth);      push_cstring(env, in_string);
912      }
   unprotect(loop); unprotect(test);  
913  }  }
914    
915    /* Reverse (flip) a list */
916  /* "for"; for-loop */  extern void rev(environment *env)
 extern void sx_666f72(environment *env)  
917  {  {
918    value *loop;    value *old_head, *new_head, *item;
   int foo1, foo2;  
919    
920    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty) {
      || CDR(CDR(env->head))==NULL) {  
921      printerr("Too Few Arguments");      printerr("Too Few Arguments");
922      env->err= 1;      env->err= 1;
923      return;      return;
924    }    }
925    
926    if(CAR(CDR(env->head))->type!=integer    if(CAR(env->head)->type==empty)
927       || CAR(CDR(CDR(env->head)))->type!=integer) {      return;                     /* Don't reverse an empty list */
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   loop= CAR(env->head);  
   protect(loop);  
   toss(env); if(env->err) return;  
   
   foo2= CAR(env->head)->content.i;  
   toss(env); if(env->err) return;  
   
   foo1= CAR(env->head)->content.i;  
   toss(env); if(env->err) return;  
   
   if(foo1<=foo2) {  
     while(foo1<=foo2) {  
       push_int(env, foo1);  
       push_val(env, loop);  
       eval(env); if(env->err) return;  
       foo1++;  
     }  
   } else {  
     while(foo1>=foo2) {  
       push_int(env, foo1);  
       push_val(env, loop);  
       eval(env); if(env->err) return;  
       foo1--;  
     }  
   }  
   unprotect(loop);  
 }  
928    
929  /* 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) {  
930      printerr("Bad Argument Type");      printerr("Bad Argument Type");
931      env->err= 2;      env->err= 2;
932      return;      return;
933    }    }
934    
935    loop= CAR(env->head);    old_head= CAR(env->head);
936    protect(loop);    new_head= new_val(env);
937    toss(env); if(env->err) return;    while(old_head->type != empty) {
938        item= old_head;
939    foo= CAR(env->head);      old_head= CDR(old_head);
940    protect(foo);      CDR(item)= new_head;
941    toss(env); if(env->err) return;      new_head= item;
   
   iterator= foo;  
   
   while(iterator!=NULL) {  
     push_val(env, CAR(iterator));  
     push_val(env, loop);  
     eval(env); if(env->err) return;  
     if (iterator->type == tcons){  
       iterator= CDR(iterator);  
     } else {  
       printerr("Bad Argument Type"); /* Improper list */  
       env->err= 2;  
       break;  
     }  
942    }    }
943    unprotect(loop); unprotect(foo);    CAR(env->head)= new_head;
944  }  }
945    
946  /* "to" */  /* Make a list. */
947  extern void to(environment *env)  extern void pack(environment *env)
948  {  {
949    int ending, start, i;    value *iterator, *temp, *ending;
   value *iterator, *temp;  
   
   if(env->head==NULL || CDR(env->head)==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
950    
951    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);  
   }  
952    
953    iterator= env->head;    iterator= env->head;
954      if(iterator->type == empty
   if(iterator==NULL  
955       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
956           && CAR(iterator)->content.sym->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
957      temp= NULL;      temp= ending;
958      toss(env);      toss(env);
959    } else {    } else {
960      /* Search for first delimiter */      /* Search for first delimiter */
961      while(CDR(iterator)!=NULL      while(CDR(iterator)->type != empty
962            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
963                || CAR(CDR(iterator))->content.sym->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
964        iterator= CDR(iterator);        iterator= CDR(iterator);
965            
966      /* Extract list */      /* Extract list */
967      temp= env->head;      temp= env->head;
968      env->head= CDR(iterator);      env->head= CDR(iterator);
969      CDR(iterator)= NULL;      CDR(iterator)= ending;
970    
971      if(env->head!=NULL)      if(env->head->type != empty)
972        toss(env);        toss(env);
973    }    }
974    
975    /* Push list */    /* Push list */
   push_val(env, temp);  
 }  
   
 /* Read a string */  
 extern void readline(environment *env)  
 {  
   char in_string[101];  
976    
977    if(fgets(in_string, 100, env->inputstream)==NULL)    push_val(env, temp);
978      push_cstring(env, "");    rev(env);
   else  
     push_cstring(env, in_string);  
979  }  }
980    
981  /* "read"; Read a value and place on stack */  /* read from a stream; used by "read" and "readport" */
982  extern void sx_72656164(environment *env)  void readstream(environment *env, FILE *stream)
983  {  {
984    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
985    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
# Line 1672  extern void sx_72656164(environment *env Line 994  extern void sx_72656164(environment *env
994    int count= -1;    int count= -1;
995    float ftemp;    float ftemp;
996    static int depth= 0;    static int depth= 0;
997    char *match, *ctemp;    char *match;
998    size_t inlength;    size_t inlength;
999    
1000    if(env->in_string==NULL) {    if(env->in_string==NULL) {
1001      if(depth > 0 && env->interactive) {      if(depth > 0 && env->interactive) {
1002        printf("]> ");        printf("]> ");
1003      }      }
1004      readline(env); if(env->err) return;      readlinestream(env, env->inputstream);
1005        if(env->err) return;
1006    
1007      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){      if((CAR(env->head)->content.string)[0]=='\0'){
1008        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1009        return;        return;
1010      }      }
1011            
1012      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.string)+1);
1013        assert(env->in_string != NULL);
1014      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1015      strcpy(env->in_string, CAR(env->head)->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.string);
1016      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1017    }    }
1018        
1019    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1020    match= malloc(inlength);    match= malloc(inlength);
1021      assert(match != NULL);
1022    
1023    if(sscanf(env->in_string, blankform, &readlength) != EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1024       && readlength != -1) {       && readlength != -1) {
# Line 1706  extern void sx_72656164(environment *env Line 1031  extern void sx_72656164(environment *env
1031      } else {      } else {
1032        push_float(env, ftemp);        push_float(env, ftemp);
1033      }      }
1034      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1035                && readlength != -1) {
1036        push_cstring(env, "");
1037    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1038              && readlength != -1) {              && readlength != -1) {
1039      push_cstring(env, match);      push_cstring(env, match);
# Line 1734  extern void sx_72656164(environment *env Line 1062  extern void sx_72656164(environment *env
1062    free(match);    free(match);
1063    
1064    if(depth)    if(depth)
1065      return sx_72656164(env);      return readstream(env, env->inputstream);
 }  
   
 #ifdef __linux__  
 extern void beep(environment *env)  
 {  
   int freq, dur, period, ticks;  
   
   if(env->head==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);  
1066  }  }
1067    
1068  extern void copying(environment *env)  extern void copying(environment *env)
1069  {  {
1070    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
1071                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1072  \n\  \n\
1073   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 1350  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER
1350  POSSIBILITY OF SUCH DAMAGES.\n");  POSSIBILITY OF SUCH DAMAGES.\n");
1351  }  }
1352    
1353  /* "*" */  /* General assoc function */
1354  extern void sx_2a(environment *env)  void assocgen(environment *env, funcp eqfunc)
1355  {  {
1356    int a, b;    value *key, *item;
   float fa, fb;  
1357    
1358    if(env->head==NULL || CDR(env->head)==NULL) {    /* Needs two values on the stack, the top one must be an association
1359         list */
1360      if(env->head->type==empty || CDR(env->head)->type==empty) {
1361      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1362      env->err= 1;      env->err= 1;
1363      return;      return;
1364    }    }
     
   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;  
   }  
1365    
1366    if(CAR(env->head)->type==tfloat    if(CAR(env->head)->type!=tcons) {
1367       && CAR(CDR(env->head))->type==tfloat) {      printerr("Bad Argument Type");
1368      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);  
       
1369      return;      return;
1370    }    }
1371    
1372    if(CAR(env->head)->type==tfloat    key=CAR(CDR(env->head));
1373       && 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;  
   }  
1374    
1375    if(CAR(env->head)->type==integer    while(item->type == tcons){
1376       && CAR(CDR(env->head))->type==tfloat) {      if(CAR(item)->type != tcons){
1377      a= CAR(env->head)->content.i;        printerr("Bad Argument Type");
1378      toss(env); if(env->err) return;        env->err= 2;
1379      fb= CAR(env->head)->content.f;        return;
1380      toss(env); if(env->err) return;      }
1381      push_float(env, fb*a);      push_val(env, key);
1382        push_val(env, CAR(CAR(item)));
1383        eqfunc(env); if(env->err) return;
1384    
1385        /* Check the result of 'eqfunc' */
1386        if(env->head->type==empty) {
1387          printerr("Too Few Arguments");
1388          env->err= 1;
1389      return;      return;
1390    }      }
1391        if(CAR(env->head)->type!=integer) {
1392    printerr("Bad Argument Type");        printerr("Bad Argument Type");
1393    env->err= 2;        env->err= 2;
1394  }        return;
1395        }
 /* "/" */  
 extern void sx_2f(environment *env)  
 {  
   int a, b;  
   float fa, fb;  
1396    
1397    if(env->head==NULL || CDR(env->head)==NULL) {      if(CAR(env->head)->content.i){
1398      printerr("Too Few Arguments");        toss(env); if(env->err) return;
1399      env->err= 1;        break;
1400      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;  
1401      toss(env); if(env->err) return;      toss(env); if(env->err) return;
     push_float(env, b/a);  
1402    
1403      return;      if(item->type!=tcons) {
1404    }        printerr("Bad Argument Type");
1405          env->err= 2;
1406    if(CAR(env->head)->type==tfloat        return;
1407       && 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;  
   }  
1408    
1409    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;  
1410    }    }
1411    
1412    if(CAR(env->head)->type==integer    if(item->type == tcons){      /* A match was found */
1413       && CAR(CDR(env->head))->type==tfloat) {      push_val(env, CAR(item));
1414      a= CAR(env->head)->content.i;    } else {
1415      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;  
1416    }    }
1417      swap(env); if(env->err) return;
1418    printerr("Bad Argument Type");    toss(env); if(env->err) return;
1419    env->err= 2;    swap(env); if(env->err) return;
1420      toss(env);
1421  }  }
1422    
1423  /* "mod" */  /* Discard the top element of the stack. */
1424  extern void mod(environment *env)  extern void toss(environment *env)
1425  {  {
1426    int a, b;    if(env->head->type==empty) {
   
   if(env->head==NULL || CDR(env->head)==NULL) {  
1427      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1428      env->err= 1;      env->err= 1;
1429      return;      return;
1430    }    }
1431        
1432    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;  
1433  }  }
1434    
 /* "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.128
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26