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

Diff of /stack/stack.c

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

revision 1.109 by masse, Thu Mar 14 10:39:11 2002 UTC revision 1.126 by masse, Mon Aug 4 11:22:02 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 188  extern void gc_init(environment *env) Line 144  extern void gc_init(environment *env)
144    if(env->interactive)    if(env->interactive)
145      printf(".");      printf(".");
146    
   
147    env->gc_count= 0;    env->gc_count= 0;
148    
149    while(env->gc_ref!=NULL) {    /* Sweep unused values */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
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;
173        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
174        env->gc_ref= titem;        env->gc_ref= titem;
175        continue;        continue;
176      }      }
177    #ifdef DEBUG
178        printf("Kept value (%p)", env->gc_ref->item);
179        if(env->gc_ref->item->gc.flag.mark)
180          printf(" (marked)");
181        if(env->gc_ref->item->gc.flag.protect)
182          printf(" (protected)");
183        switch(env->gc_ref->item->type){
184        case integer:
185          printf(" integer: %d", env->gc_ref->item->content.i);
186          break;
187        case func:
188          printf(" func: %p", env->gc_ref->item->content.ptr);
189          break;
190        case symb:
191          printf(" symb: %s", env->gc_ref->item->content.sym->id);
192          break;
193        case tcons:
194          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
195                 env->gc_ref->item->content.c->cdr);
196          break;
197        default:
198          printf(" <unknown %d>", (env->gc_ref->item->type));
199        }
200        printf("\n");
201    #endif /* DEBUG */
202    
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 223  extern void gc_init(environment *env) Line 218  extern void gc_init(environment *env)
218    env->gc_ref= new_head;    env->gc_ref= new_head;
219    
220    if(env->interactive)    if(env->interactive)
221      printf("done\n");      printf("done (%d bytes still allocated)\n", env->gc_count);
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 */
# Line 260  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 297  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 311  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 328  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 380  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 416  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)
 {  
   printf("\n");  
 }  
   
 /* Gets the type of a value */  
 extern void type(environment *env)  
429  {  {
430    int typenum;    stackitem *titem, *tstack;
431      int depth;
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            if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
514              perror("print_val");
515              env->err= 5;
516              free(titem);
517              return;
518            }
519          } else {
520            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  extern void princ_(environment *env)    printval_end:
 {  
   if(env->head==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   print_h(env->head, 1);  
 }  
560    
561  /* Prints the top element of the stack and then discards it. */      titem=tstack;
562  extern void princ(environment *env)      while(titem != stack){
563  {        tstack=titem->next;
564    princ_(env);        free(titem);
565    if(env->err) return;        titem=tstack;
566    toss(env);      }
 }  
   
 /* Only to be called by function printstack. */  
 void print_st(value *stack_head, long counter)  
 {  
   if(CDR(stack_head) != NULL)  
     print_st(CDR(stack_head), counter+1);  
   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 556  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 567  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 607  extern void rcl(environment *env) Line 614  extern void rcl(environment *env)
614      env->err= 3;      env->err= 3;
615      return;      return;
616    }    }
617    protect(val);    push_val(env, val);           /* Return the symbol's bound value */
618    toss(env);            /* toss the symbol */    swap(env);
619      if(env->err) return;
620      toss(env);                    /* toss the symbol */
621    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(val);  
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 627  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 658  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 666  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)->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 683  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! */  
   
721  }  }
722    
 /* 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);  
 }  
   
 /* 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 887  extern void quit(environment *env) Line 739  extern void quit(environment *env)
739    env->gc_limit= 0;    env->gc_limit= 0;
740    gc_maybe(env);    gc_maybe(env);
741    
742      words(env);
743    
744    if(env->free_string!=NULL)    if(env->free_string!=NULL)
745      free(env->free_string);      free(env->free_string);
746        
# Line 897  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) {  
       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 931  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 983  int main(int argc, char **argv) Line 806  int main(int argc, char **argv)
806          break;          break;
807        case '?':        case '?':
808          fprintf (stderr,          fprintf (stderr,
809                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
810                   optopt);                   optopt);
811          return EX_USAGE;          return EX_USAGE;
812        default:        default:
# Line 1002  int main(int argc, char **argv) Line 825  int main(int argc, char **argv)
825    if(myenv.interactive) {    if(myenv.interactive) {
826      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
827  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
828  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
829  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
830  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
831    }    }
832    
833    while(1) {    while(1) {
# Line 1012  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);      readstream(&myenv, myenv.inputstream);
847      if (myenv.err==4) {      if (myenv.err) {            /* EOF or other error */
848        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
849      } else if(myenv.head!=NULL        quit(&myenv);
850        } 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 1265  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 1274  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 1282  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)  
903  {  {
904    int truth;    char in_string[101];
   
   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)  
 {  
   int truth;  
   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 1641  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 1656  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 1663  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 1675  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 1703  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 2059  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;  
   }  
   
   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;  
   }  
1367    
1368    if(CAR(env->head)->type==tfloat    if(CAR(env->head)->type!=tcons) {
1369       && CAR(CDR(env->head))->type==integer) {      printerr("Bad Argument Type");
1370      fa= CAR(env->head)->content.f;      env->err= 2;
     toss(env); if(env->err) return;  
     b= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     push_float(env, b*fa);  
       
1371      return;      return;
1372    }    }
1373    
1374    if(CAR(env->head)->type==integer    key=CAR(CDR(env->head));
1375       && CAR(CDR(env->head))->type==tfloat) {    item=CAR(env->head);
     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);  
1376    
1377      while(item->type == tcons){
1378        if(CAR(item)->type != tcons){
1379          printerr("Bad Argument Type");
1380          env->err= 2;
1381          return;
1382        }
1383        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);  
   
     return;  
   }  
1404    
1405    if(CAR(env->head)->type==tfloat      if(item->type!=tcons) {
1406       && CAR(CDR(env->head))->type==tfloat) {        printerr("Bad Argument Type");
1407      fa= CAR(env->head)->content.f;        env->err= 2;
1408      toss(env); if(env->err) return;        return;
1409      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.109  
changed lines
  Added in v.1.126
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26