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

Diff of /stack/stack.c

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

revision 1.94 by masse, Sat Mar 9 09:58:31 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    
 /* 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>  
 /* mtrace, muntrace */  
 #include <mcheck.h>  
 /* ioctl */  
 #include <sys/ioctl.h>  
 /* KDMKTONE */  
 #include <linux/kd.h>  
   
24  #include "stack.h"  #include "stack.h"
25    
26  /* Initialize a newly created environment */  /* Initialize a newly created environment */
# Line 48  void init_env(environment *env) Line 28  void init_env(environment *env)
28  {  {
29    int i;    int i;
30    
31    env->gc_limit= 20;    env->gc_limit= 400000;
32    env->gc_count= 0;    env->gc_count= 0;
33    env->gc_ref= NULL;    env->gc_ref= NULL;
   env->gc_protect= 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 63  void init_env(environment *env) Line 42  void init_env(environment *env)
42    env->interactive= 1;    env->interactive= 1;
43  }  }
44    
45  void printerr(const char* in_string) {  void printerr(const char* in_string)
   fprintf(stderr, "Err: %s\n", in_string);  
 }  
   
 /* Discard the top element of the stack. */  
 extern void toss(environment *env)  
46  {  {
47    stackitem *temp= env->head;    fprintf(stderr, "Err: %s\n", in_string);
   
   if((env->head)==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   env->head= env->head->next;   /* Remove the top stack item */  
   free(temp);                   /* Free the old top stack item */  
   
   gc_init(env);  
48  }  }
49    
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. */
# Line 113  symbol **hash(hashtbl in_hashtbl, const Line 76  symbol **hash(hashtbl in_hashtbl, const
76    }    }
77  }  }
78    
79  value* new_val(environment *env) {  /* Create new value */
80    value* new_val(environment *env)
81    {
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= empty;
90    
91    nitem->item= nval;    nitem->item= nval;
92    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
   env->gc_ref= nitem;  
93    
94    env->gc_count++;    env->gc_ref= nitem;
95    
96    protect(env, nval);    env->gc_count += sizeof(value);
97    gc_init(env);    nval->gc.flag.mark= 0;
98    unprotect(env);    nval->gc.flag.protect= 0;
99    
100    return nval;    return nval;
101  }  }
102    
 void gc_mark(value *val) {  
   stackitem *iterator;  
103    
104    if(val==NULL || val->gc_garb==0)  /* Mark values recursively.
105       Marked values are not collected by the GC. */
106    inline void gc_mark(value *val)
107    {
108      if(val==NULL || val->gc.flag.mark)
109      return;      return;
110    
111    val->gc_garb= 0;    val->gc.flag.mark= 1;
   
   if(val->type==list) {  
     iterator= val->content.ptr;  
112    
113      while(iterator!=NULL) {    if(val->type==tcons) {
114        gc_mark(iterator->item);      gc_mark(CAR(val));
115        iterator= iterator->next;      gc_mark(CDR(val));
     }  
116    }    }
117  }  }
118    
119  extern void gc_init(environment *env) {  
120    stackitem *new_head= NULL, *titem, *iterator;  /* Start GC */
121    extern void gc_init(environment *env)
122    {
123      stackitem *new_head= NULL, *titem;
124    symbol *tsymb;    symbol *tsymb;
125    int i;    int i;
126    
127    if(env->gc_count < env->gc_limit)    if(env->interactive)
128      return;      printf("Garbage collecting.");
129    
130    /* Garb by default */    /* Mark values on stack */
131    iterator= env->gc_ref;    gc_mark(env->head);
   while(iterator!=NULL) {  
     iterator->item->gc_garb= 1;  
     iterator= iterator->next;  
   }  
132    
133    /* Mark protected values */    if(env->interactive)
134    iterator= env->gc_protect;      printf(".");
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
135    
   /* Mark values in stack */  
   iterator= env->head;  
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
136    
137    /* Mark values in hashtable */    /* Mark values in hashtable */
138    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++)
139      tsymb= env->symbols[i];      for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
140      while(tsymb!=NULL) {        if (tsymb->val != NULL)
141        gc_mark(tsymb->val);          gc_mark(tsymb->val);
142        tsymb= tsymb->next;  
143      }  
144    }    if(env->interactive)
145        printf(".");
146    
147    env->gc_count= 0;    env->gc_count= 0;
148    
149    /* Sweep */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
   while(env->gc_ref!=NULL) {  
150    
151      if(env->gc_ref->item->gc_garb) {      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
152    
153        /* Remove content */        /* Remove content */
154        switch(env->gc_ref->item->type) {        switch(env->gc_ref->item->type){
155        case string:        case string:
156          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
157          break;          break;
158        case list:        case tcons:
159          while(env->gc_ref->item->content.ptr!=NULL) {          free(env->gc_ref->item->content.c);
           titem= env->gc_ref->item->content.ptr;  
           env->gc_ref->item->content.ptr= titem->next;  
           free(titem);  
         }  
160          break;          break;
161        default:        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;          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      } else {                    /* Save */        continue;
176        titem= env->gc_ref->next;      }
177        env->gc_ref->next= new_head;  #ifdef DEBUG
178        new_head= env->gc_ref;      printf("Kept value (%p)", env->gc_ref->item);
179        env->gc_ref= titem;      if(env->gc_ref->item->gc.flag.mark)
180        env->gc_count++;        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 */    
204        env->gc_count += sizeof(value);
205        if(env->gc_ref->item->type==string)
206          env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
207        
208        titem= env->gc_ref->next;
209        env->gc_ref->next= new_head;
210        new_head= env->gc_ref;
211        new_head->item->gc.flag.mark= 0;
212        env->gc_ref= titem;
213    }    }
214    
215    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
216        env->gc_limit= env->gc_count*2;
217    
218    env->gc_ref= new_head;    env->gc_ref= new_head;
219    
220      if(env->interactive)
221        printf("done (%d bytes still allocated)\n", env->gc_count);
222    
223  }  }
224    
225  void protect(environment *env, value *val)  inline void gc_maybe(environment *env)
226  {  {
227    stackitem *new_item= malloc(sizeof(stackitem));    if(env->gc_count < env->gc_limit)
228    new_item->item= val;      return;
229    new_item->next= env->gc_protect;    else
230    env->gc_protect= new_item;      return gc_init(env);
231  }  }
232    
233  void unprotect(environment *env)  /* Protect values from GC */
234    void protect(value *val)
235  {  {
236    stackitem *temp= env->gc_protect;    if(val==NULL || val->gc.flag.protect)
237    env->gc_protect= env->gc_protect->next;      return;
238    free(temp);  
239      val->gc.flag.protect= 1;
240    
241      if(val->type==tcons) {
242        protect(CAR(val));
243        protect(CDR(val));
244      }
245    }
246    
247    /* Unprotect values from GC */
248    void unprotect(value *val)
249    {
250      if(val==NULL || !(val->gc.flag.protect))
251        return;
252    
253      val->gc.flag.protect= 0;
254    
255      if(val->type==tcons) {
256        unprotect(CAR(val));
257        unprotect(CDR(val));
258      }
259  }  }
260    
261  /* Push a value onto the stack */  /* Push a value onto the stack */
262  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
263  {  {
264    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
265    new_item->item= val;  
266    new_item->next= env->head;    new_value->content.c= malloc(sizeof(pair));
267    env->head= new_item;    assert(new_value->content.c!=NULL);
268      env->gc_count += sizeof(pair);
269      new_value->type= tcons;
270      CAR(new_value)= val;
271      CDR(new_value)= env->head;
272      env->head= new_value;
273  }  }
274    
275  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
276  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
277  {  {
278    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 262  void push_int(environment *env, int in_v Line 283  void push_int(environment *env, int in_v
283    push_val(env, new_value);    push_val(env, new_value);
284  }  }
285    
286    /* Push a floating point number onto the stack */
287  void push_float(environment *env, float in_val)  void push_float(environment *env, float in_val)
288  {  {
289    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 276  void push_float(environment *env, float Line 298  void push_float(environment *env, float
298  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
299  {  {
300    value *new_value= new_val(env);    value *new_value= new_val(env);
301      int length= strlen(in_string)+1;
302    
303    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
304      assert(new_value != NULL);
305      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;
308    
# Line 285  void push_cstring(environment *env, cons Line 310  void push_cstring(environment *env, cons
310  }  }
311    
312  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
313  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
314    {
315    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
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 303  char *mangle_str(const char *old_string) Line 330  char *mangle_str(const char *old_string)
330    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
331  }  }
332    
333  extern void mangle(environment *env){  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;
341    }    }
342    
343    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
344      printerr("Bad Argument Type");      printerr("Bad Argument Type");
345      env->err= 2;      env->err= 2;
346      return;      return;
347    }    }
348    
349    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
350        mangle_str((const char *)(CAR(env->head)->content.ptr));
351    
352    toss(env);    toss(env);
353    if(env->err) return;    if(env->err) return;
# Line 342  void push_sym(environment *env, const ch Line 371  void push_sym(environment *env, const ch
371    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
372    
373    new_value= new_val(env);    new_value= new_val(env);
374    protect(env, new_value);    protect(new_value);
375    new_fvalue= new_val(env);    new_fvalue= new_val(env);
376    protect(env, new_fvalue);    protect(new_fvalue);
377    
378    /* The new value is a symbol */    /* The new value is a symbol */
379    new_value->type= symb;    new_value->type= symb;
# Line 357  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 372  void push_sym(environment *env, const ch Line 403  void push_sym(environment *env, const ch
403    
404      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
405      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
406      free(mangled);  
407      dlerr= dlerror();      dlerr= dlerror();
408      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
409        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
410        dlerr= dlerror();        dlerr= dlerror();
411      }      }
412    
413      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
414        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
415        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
416        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
417                                           function value */                                           function value */
418      }      }
419    
420        free(mangled);
421    }    }
422    
423    push_val(env, new_value);    push_val(env, new_value);
424    unprotect(env); unprotect(env);    unprotect(new_value); unprotect(new_fvalue);
425  }  }
426    
427  /* Print newline. */  /* Print a value */
428  extern void nl()  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
429  {  {
430    printf("\n");    stackitem *titem, *tstack;
431  }    int depth;
432    
433  /* Gets the type of a value */    switch(val->type) {
434  extern void type(environment *env){    case empty:
435    int typenum;      if(fprintf(stream, "[]") < 0){
436          perror("print_val");
437    if((env->head)==NULL) {        env->err= 5;
438      printerr("Too Few Arguments");        return;
439      env->err=1;      }
     return;  
   }  
   typenum=env->head->item->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 list:  
     push_sym(env, "list");  
440      break;      break;
   }  
 }      
   
 /* Prints the top element of the stack. */  
 void print_h(stackitem *stack_head, int noquote)  
 {  
   switch(stack_head->item->type) {  
441    case integer:    case integer:
442      printf("%d", stack_head->item->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", stack_head->item->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*)stack_head->item->content.ptr);        if(fprintf(stream, "%s", (char*)(val->content.ptr)) < 0){
458      else          perror("print_val");
459        printf("\"%s\"", (char*)stack_head->item->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", ((symbol *)(stack_head->item->content.ptr))->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)(stack_head->item->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 list:    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=(stackitem *)(stack_head->item->content.ptr);        perror("print_val");
487      printf("[ ");        env->err= 5;
488      while(stack_head != NULL) {        return;
       print_h(stack_head, noquote);  
       printf(" ");  
       stack_head=stack_head->next;  
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    if(env->head==NULL) {        return;
496      printerr("Too Few Arguments");      }
497      env->err=1;      tstack= stack;
498      return;      do {
499    }        titem=malloc(sizeof(stackitem));
500    print_h(env->head, 0);        assert(titem != NULL);
501    nl();        titem->item=val;
502  }        titem->next=tstack;
503          tstack=titem;             /* Put it on the stack */
504  /* Prints the top element of the stack and then discards it. */        /* Search a stack of values being printed to see if we are already
505  extern void print(environment *env)           printing this value */
506  {        titem=tstack;
507    print_(env);        depth=0;
508    if(env->err) return;        while(titem != NULL && titem->item != CAR(val)){
509    toss(env);          titem=titem->next;
510  }          depth++;
511          }
512  extern void princ_(environment *env) {        if(titem != NULL){        /* If we found it on the stack, */
513    if(env->head==NULL) {          if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
514      printerr("Too Few Arguments");            perror("print_val");
515      env->err=1;            env->err= 5;
516      return;            free(titem);
517    }            return;
518    print_h(env->head, 1);          }
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  /* Prints the top element of the stack and then discards it. */    printval_end:
 extern void princ(environment *env)  
 {  
   princ_(env);  
   if(env->err) return;  
   toss(env);  
 }  
560    
561  /* Only to be called by function printstack. */      titem=tstack;
562  void print_st(stackitem *stack_head, long counter)      while(titem != stack){
563  {        tstack=titem->next;
564    if(stack_head->next != NULL)        free(titem);
565      print_st(stack_head->next, counter+1);        titem=tstack;
566    printf("%ld: ", counter);      }
   print_h(stack_head, 0);  
   nl();  
 }  
567    
568  /* Prints the stack. */      if(! (env->err)){
569  extern void printstack(environment *env)        if(fprintf(stream, " ]") < 0){
570  {          perror("print_val");
571    if(env->head == NULL) {          env->err= 5;
572      printf("Stack Empty\n");        }
573      return;      }
574        break;
575    }    }
   print_st(env->head, 1);  
576  }  }
577    
578  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
579  extern void swap(environment *env)  extern void swap(environment *env)
580  {  {
581    stackitem *temp= env->head;    value *temp= env->head;
582        
583    if(env->head==NULL || env->head->next==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;
587    }    }
588    
589    env->head= env->head->next;    env->head= CDR(env->head);
590    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
591    env->head->next= temp;    CDR(env->head)= temp;
592  }  }
593    
 /* Rotate the first three elements on the stack. */  
 extern void rot(environment *env)  
 {  
   stackitem *temp= env->head;  
     
   if(env->head==NULL || env->head->next==NULL  
       || env->head->next->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
   
   env->head= env->head->next->next;  
   temp->next->next= env->head->next;  
   env->head->next= 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;
603    }    }
604    
605    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
606      printerr("Bad Argument Type");      printerr("Bad Argument Type");
607      env->err=2;      env->err= 2;
608      return;      return;
609    }    }
610    
611    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
612    if(val == NULL){    if(val == NULL){
613      printerr("Unbound Variable");      printerr("Unbound Variable");
614      env->err=3;      env->err= 3;
615      return;      return;
616    }    }
617    protect(env, 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(env);  
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 589  extern void eval(environment *env) Line 629  extern void eval(environment *env)
629  {  {
630    funcp in_func;    funcp in_func;
631    value* temp_val;    value* temp_val;
632    stackitem* iterator;    value* iterator;
633    
634   eval_start:   eval_start:
635    
636    if(env->head==NULL) {    gc_maybe(env);
637    
638      if(env->head->type==empty) {
639      printerr("Too Few Arguments");      printerr("Too Few Arguments");
640      env->err=1;      env->err= 1;
641      return;      return;
642    }    }
643    
644    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
645      /* if it's a symbol */      /* if it's a symbol */
646    case symb:    case symb:
647      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
648      if(env->err) return;      if(env->err) return;
649      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
650        goto eval_start;        goto eval_start;
651      }      }
652      return;      return;
653    
654      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
655    case func:    case func:
656      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
657      toss(env);      toss(env);
658      if(env->err) return;      if(env->err) return;
659      return in_func(env);      return in_func(env);
660    
661      /* If it's a list */      /* If it's a list */
662    case list:    case tcons:
663      temp_val= env->head->item;      temp_val= CAR(env->head);
664      protect(env, temp_val);      protect(temp_val);
665    
666      toss(env); if(env->err) return;      toss(env); if(env->err) return;
667      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
668            
669      while(iterator!=NULL) {      while(iterator->type != empty) {
670        push_val(env, iterator->item);        push_val(env, CAR(iterator));
671                
672        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
673          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
674          toss(env);          toss(env);
675          if(env->err) return;          if(env->err) return;
676                    
677          if(iterator->next == 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        iterator= iterator->next;        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
684            iterator= CDR(iterator);
685          else {
686            printerr("Bad Argument Type"); /* Improper list */
687            env->err= 2;
688            return;
689          }
690      }      }
691      unprotect(env);      unprotect(temp_val);
     return;  
   
   default:  
     return;  
   }  
 }  
   
 /* Reverse (flip) a list */  
 extern void rev(environment *env){  
   stackitem *old_head, *new_head, *item;  
   
   if((env->head)==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
692      return;      return;
   }  
   
   if(env->head->item->type!=list) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   old_head= (stackitem *)(env->head->item->content.ptr);  
   new_head= NULL;  
   while(old_head != NULL){  
     item= old_head;  
     old_head= old_head->next;  
     item->next= new_head;  
     new_head= item;  
   }  
   env->head->item->content.ptr= new_head;  
 }  
   
 /* Make a list. */  
 extern void pack(environment *env)  
 {  
   stackitem *iterator, *temp;  
   value *pack;  
   
   iterator= env->head;  
   pack= new_val(env);  
   protect(env, pack);  
693    
694    if(iterator==NULL    case empty:
695       || (iterator->item->type==symb      toss(env);
696       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {    case integer:
697      temp= NULL;    case tfloat:
698      toss(env);    case string:
699    } else {    case port:
     /* Search for first delimiter */  
     while(iterator->next!=NULL  
           && (iterator->next->item->type!=symb  
           || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))  
       iterator= iterator->next;  
       
     /* Extract list */  
     temp= env->head;  
     env->head= iterator->next;  
     iterator->next= NULL;  
   
     pack->type= list;  
     pack->content.ptr= temp;  
       
     if(env->head!=NULL)  
       toss(env);  
   }  
   
   /* Push list */  
   
   push_val(env, pack);  
   rev(env);  
   
   unprotect(env);  
 }  
   
 /* Relocate elements of the list on the stack. */  
 extern void expand(environment *env)  
 {  
   stackitem *temp, *new_head;  
   
   /* Is top element a list? */  
   if(env->head==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   if(env->head->item->type!=list) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
700      return;      return;
701    }    }
   
   rev(env);  
   
   if(env->err)  
     return;  
   
   /* The first list element is the new stack head */  
   new_head= temp= env->head->item->content.ptr;  
   
   toss(env);  
   
   /* Find the end of the list */  
   while(temp->next!=NULL)  
     temp= temp->next;  
   
   /* Connect the tail of the list with the old stack head */  
   temp->next= env->head;  
   env->head= new_head;          /* ...and voila! */  
   
702  }  }
703    
704  /* Compares two elements by reference. */  /* List all defined words */
705  extern void eq(environment *env)  extern void words(environment *env)
706  {  {
707    void *left, *right;    symbol *temp;
708    int result;    int i;
   
   if((env->head)==NULL || env->head->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   left= env->head->item->content.ptr;  
   swap(env);  
   right= env->head->item->content.ptr;  
   result= (left==right);  
709        
710    toss(env); toss(env);    for(i= 0; i<HASHTBLSIZE; i++) {
711    push_int(env, result);      temp= env->symbols[i];
712  }      while(temp!=NULL) {
713    #ifdef DEBUG
714  /* Negates the top element on the stack. */        if (temp->val != NULL && temp->val->gc.flag.protect)
715  extern void not(environment *env)          printf("(protected) ");
716  {  #endif /* DEBUG */
717    int val;        printf("%s ", temp->id);
718          temp= temp->next;
719    if((env->head)==NULL) {      }
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->item->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
720    }    }
   
   val= env->head->item->content.i;  
   toss(env);  
   push_int(env, !val);  
 }  
   
 /* Compares the two top elements on the stack and return 0 if they're the  
    same. */  
 extern void neq(environment *env)  
 {  
   eq(env);  
   not(env);  
721  }  }
722    
 /* Give a symbol some content. */  
 extern void def(environment *env)  
 {  
   symbol *sym;  
   
   /* Needs two values on the stack, the top one must be a symbol */  
   if(env->head==NULL || env->head->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->item->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   /* long names are a pain */  
   sym= env->head->item->content.ptr;  
   
   /* Bind the symbol to the value */  
   sym->val= env->head->next->item;  
   
   toss(env); toss(env);  
 }  
   
723  /* Quit stack. */  /* Quit stack. */
724  extern void quit(environment *env)  extern void quit(environment *env)
725  {  {
726    long 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 848  extern void quit(environment *env) Line 737  extern void quit(environment *env)
737    }    }
738    
739    env->gc_limit= 0;    env->gc_limit= 0;
740    gc_init(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        
747    #ifdef __linux__
748    muntrace();    muntrace();
749    #endif
750    
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    {
757    symbol *temp;    symbol *temp;
758    
759    temp= *hash_entry;    temp= *hash_entry;
# Line 891  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    stackitem *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(stack_head->item->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err=2;  
781      return;      return;
782    }    }
783    
784    sym_id= ((symbol*)(stack_head->item->content.ptr))->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 926  int main(int argc, char **argv) Line 790  int main(int argc, char **argv)
790    
791    int c;                        /* getopt option character */    int c;                        /* getopt option character */
792    
793    #ifdef __linux__
794    mtrace();    mtrace();
795    #endif
796    
797    init_env(&myenv);    init_env(&myenv);
798    
# Line 940  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 959  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 969  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                && myenv.head->item->type==symb      } else if(myenv.head->type!=empty
851                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->type==symb
852        toss(&myenv);             /* No error check in main */                && CAR(myenv.head)->content.sym->id[0] == ';') {
853          toss(&myenv); if(myenv.err) continue;
854        eval(&myenv);        eval(&myenv);
855        } else {
856          gc_maybe(&myenv);
857      }      }
     gc_init(&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 || env->head->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->item->type==string  
      && env->head->next->item->type==string) {  
     a_val= env->head->item;  
     b_val= env->head->next->item;  
     protect(env, a_val); protect(env, 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(env); unprotect(env);  
     free(new_string);  
       
     return;  
   }  
     
   if(env->head->item->type==integer  
      && env->head->next->item->type==integer) {  
     a=env->head->item->content.i;  
     toss(env); if(env->err) return;  
     b=env->head->item->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b+a);  
   
     return;  
   }  
   
   if(env->head->item->type==tfloat  
      && env->head->next->item->type==tfloat) {  
     fa= env->head->item->content.f;  
     toss(env); if(env->err) return;  
     fb= env->head->item->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb+fa);  
       
     return;  
   }  
   
   if(env->head->item->type==tfloat  
      && env->head->next->item->type==integer) {  
     fa= env->head->item->content.f;  
     toss(env); if(env->err) return;  
     b= env->head->item->content.i;  
     toss(env); if(env->err) return;  
     push_float(env, b+fa);  
       
     return;  
   }  
   
   if(env->head->item->type==integer  
      && env->head->next->item->type==tfloat) {  
     a= env->head->item->content.i;  
     toss(env); if(env->err) return;  
     fb= env->head->item->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 || env->head->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
     
   if(env->head->item->type==integer  
      && env->head->next->item->type==integer) {  
     a=env->head->item->content.i;  
     toss(env); if(env->err) return;  
     b=env->head->item->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b-a);  
   
     return;  
   }  
   
   if(env->head->item->type==tfloat  
      && env->head->next->item->type==tfloat) {  
     fa= env->head->item->content.f;  
     toss(env); if(env->err) return;  
     fb= env->head->item->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb-fa);  
       
     return;  
   }  
   
   if(env->head->item->type==tfloat  
      && env->head->next->item->type==integer) {  
     fa= env->head->item->content.f;  
     toss(env); if(env->err) return;  
     b= env->head->item->content.i;  
     toss(env); if(env->err) return;  
     push_float(env, b-fa);  
       
     return;  
   }  
   
   if(env->head->item->type==integer  
      && env->head->next->item->type==tfloat) {  
     a= env->head->item->content.i;  
     toss(env); if(env->err) return;  
     fb= env->head->item->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 || env->head->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
     
   if(env->head->item->type==integer  
      && env->head->next->item->type==integer) {  
     a=env->head->item->content.i;  
     toss(env); if(env->err) return;  
     b=env->head->item->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b>a);  
   
     return;  
   }  
   
   if(env->head->item->type==tfloat  
      && env->head->next->item->type==tfloat) {  
     fa= env->head->item->content.f;  
     toss(env); if(env->err) return;  
     fb= env->head->item->content.f;  
     toss(env); if(env->err) return;  
     push_int(env, fb>fa);  
       
     return;  
   }  
   
   if(env->head->item->type==tfloat  
      && env->head->next->item->type==integer) {  
     fa= env->head->item->content.f;  
     toss(env); if(env->err) return;  
     b= env->head->item->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b>fa);  
       
     return;  
   }  
   
   if(env->head->item->type==integer  
      && env->head->next->item->type==tfloat) {  
     a= env->head->item->content.i;  
     toss(env); if(env->err) return;  
     fb= env->head->item->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    stackitem *old_item, *new_item, *prev_item;  {
866    value *new_value;    value *new_value;
867    
868    protect(env, old_value);    if(old_value==NULL)
869        return NULL;
870    
871    new_value= new_val(env);    new_value= new_val(env);
   protect(env, new_value);  
872    new_value->type= old_value->type;    new_value->type= old_value->type;
873    
874    switch(old_value->type){    switch(old_value->type){
# Line 1222  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:
884      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
885        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
886      break;      break;
887    case list:    case tcons:
     new_value->content.ptr= NULL;  
888    
889      prev_item= NULL;      new_value->content.c= malloc(sizeof(pair));
890      old_item= (stackitem*)(old_value->content.ptr);      assert(new_value->content.c!=NULL);
891        env->gc_count += sizeof(pair);
892    
893      while(old_item != NULL) {   /* While list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
894        new_item= malloc(sizeof(stackitem));      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
       new_item->item= copy_val(env, old_item->item); /* recurse */  
       new_item->next= NULL;  
       if(prev_item != NULL)     /* If this wasn't the first item */  
         prev_item->next= new_item; /* point the previous item to the  
                                      new item */  
       else  
         new_value->content.ptr= new_item;  
       old_item= old_item->next;  
       prev_item= new_item;  
     }      
895      break;      break;
896    }    }
897    
   unprotect(env); unprotect(env);  
   
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)
903    if((env->head)==NULL) {  {
904      printerr("Too Few Arguments");    char in_string[101];
     env->err= 1;  
     return;  
   }  
   push_val(env, copy_val(env, env->head->item));  
 }  
   
 /* "if", If-Then */  
 extern void sx_6966(environment *env) {  
   
   int truth;  
   
   if((env->head)==NULL || env->head->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->next->item->type != integer) {  
     printerr("Bad Argument Type");  
     env->err=2;  
     return;  
   }  
     
   swap(env);  
   if(env->err) return;  
     
   truth=env->head->item->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 || env->head->next==NULL  
      || env->head->next->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
   
   if(env->head->next->next->item->type != integer) {  
     printerr("Bad Argument Type");  
     env->err=2;  
     return;  
   }  
     
   rot(env);  
   if(env->err) return;  
     
   truth=env->head->item->content.i;  
   
   toss(env);  
   if(env->err) return;  
   
   if(!truth)  
     swap(env);  
   if(env->err) return;  
   
   toss(env);  
   if(env->err) return;  
   
   eval(env);  
 }  
   
 /* "while" */  
 extern void sx_7768696c65(environment *env) {  
   
   int truth;  
   value *loop, *test;  
   
   if((env->head)==NULL || env->head->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
   
   loop= env->head->item;  
   protect(env, loop);  
   toss(env); if(env->err) return;  
   
   test= env->head->item;  
   protect(env, test);  
   toss(env); if(env->err) return;  
   
   do {  
     push_val(env, test);  
     eval(env);  
       
     if(env->head->item->type != integer) {  
       printerr("Bad Argument Type");  
       env->err= 2;  
       return;  
     }  
       
     truth= env->head->item->content.i;  
     toss(env); if(env->err) return;  
       
     if(truth) {  
       push_val(env, loop);  
       eval(env);  
     } else {  
       toss(env);  
     }  
     
   } while(truth);  
   
   unprotect(env); unprotect(env);  
 }  
   
   
 /* "for"; for-loop */  
 extern void sx_666f72(environment *env) {  
   value *loop;  
   int foo1, foo2;  
   
   if(env->head==NULL || env->head->next==NULL  
      || env->head->next->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->next->item->type!=integer  
      || env->head->next->next->item->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   loop= env->head->item;  
   protect(env, loop);  
   toss(env); if(env->err) return;  
   
   foo2= env->head->item->content.i;  
   toss(env); if(env->err) return;  
   
   foo1= env->head->item->content.i;  
   toss(env); if(env->err) return;  
905    
906    if(foo1<=foo2) {    if(fgets(in_string, 100, stream)==NULL) {
907      while(foo1<=foo2) {      push_cstring(env, "");
908        push_int(env, foo1);      if (! feof(stream)){
909        push_val(env, loop);        perror("readline");
910        eval(env); if(env->err) return;        env->err= 5;
       foo1++;  
911      }      }
912    } else {    } else {
913      while(foo1>=foo2) {      push_cstring(env, in_string);
       push_int(env, foo1);  
       push_val(env, loop);  
       eval(env); if(env->err) return;  
       foo1--;  
     }  
914    }    }
   unprotect(env);  
915  }  }
916    
917  /* Variant of for-loop */  /* Reverse (flip) a list */
918  extern void foreach(environment *env) {  extern void rev(environment *env)
919      {
920    value *loop, *foo;    value *old_head, *new_head, *item;
921    stackitem *iterator;  
922        if(env->head->type==empty) {
   if((env->head)==NULL || env->head->next==NULL) {  
923      printerr("Too Few Arguments");      printerr("Too Few Arguments");
924      env->err= 1;      env->err= 1;
925      return;      return;
926    }    }
927    
928    if(env->head->next->item->type != list) {    if(CAR(env->head)->type==empty)
929        return;                     /* Don't reverse an empty list */
930    
931      if(CAR(env->head)->type!=tcons) {
932      printerr("Bad Argument Type");      printerr("Bad Argument Type");
933      env->err= 2;      env->err= 2;
934      return;      return;
935    }    }
936    
937    loop= env->head->item;    old_head= CAR(env->head);
938    protect(env, loop);    new_head= new_val(env);
939    toss(env); if(env->err) return;    while(old_head->type != empty) {
940        item= old_head;
941    foo= env->head->item;      old_head= CDR(old_head);
942    protect(env, foo);      CDR(item)= new_head;
943    toss(env); if(env->err) return;      new_head= item;
   
   iterator= foo->content.ptr;  
   
   while(iterator!=NULL) {  
     push_val(env, iterator->item);  
     push_val(env, loop);  
     eval(env); if(env->err) return;  
     iterator= iterator->next;  
   }  
   unprotect(env); unprotect(env);  
 }  
   
 /* "to" */  
 extern void to(environment *env) {  
   int i, start, ending;  
   stackitem *temp_head;  
   value *temp_val;  
     
   if((env->head)==NULL || env->head->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
   
   if(env->head->item->type!=integer  
      || env->head->next->item->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err=2;  
     return;  
944    }    }
945      CAR(env->head)= new_head;
946    }
947    
948    ending= env->head->item->content.i;  /* Make a list. */
949    toss(env); if(env->err) return;  extern void pack(environment *env)
950    start= env->head->item->content.i;  {
951    toss(env); if(env->err) return;    value *iterator, *temp, *ending;
952    
953    temp_head= env->head;    ending=new_val(env);
   env->head= NULL;  
954    
955    if(ending>=start) {    iterator= env->head;
956      for(i= ending; i>=start; i--)    if(iterator->type == empty
957        push_int(env, i);       || (CAR(iterator)->type==symb
958         && CAR(iterator)->content.sym->id[0]=='[')) {
959        temp= ending;
960        toss(env);
961    } else {    } else {
962      for(i= ending; i<=start; i++)      /* Search for first delimiter */
963        push_int(env, i);      while(CDR(iterator)->type != empty
964    }            && (CAR(CDR(iterator))->type!=symb
965               || CAR(CDR(iterator))->content.sym->id[0]!='['))
966    temp_val= new_val(env);        iterator= CDR(iterator);
967    protect(env, temp_val);      
968        /* Extract list */
969    temp_val->content.ptr= env->head;      temp= env->head;
970    temp_val->type= list;      env->head= CDR(iterator);
971    env->head= temp_head;      CDR(iterator)= ending;
   push_val(env, temp_val);  
972    
973    unprotect(env);      if(env->head->type != empty)
974  }        toss(env);
975      }
976    
977  /* Read a string */    /* Push list */
 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";
988    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1532  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 *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1010        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1011        return;        return;
1012      }      }
1013            
1014      env->in_string= malloc(strlen(env->head->item->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, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1018      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1019    }    }
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 1566  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 1594  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);
1068  }  }
1069    
1070  extern void beep(environment *env) {  extern void copying(environment *env)
1071    {
1072    int freq, dur, period, ticks;    printf("                  GNU GENERAL PUBLIC LICENSE\n\
   
   if((env->head)==NULL || env->head->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
   
   if(env->head->item->type!=integer  
      || env->head->next->item->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err=2;  
     return;  
   }  
   
   dur=env->head->item->content.i;  
   toss(env);  
   freq=env->head->item->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();  
   }  
 };  
   
 /* "wait" */  
 extern void sx_77616974(environment *env) {  
   
   int dur;  
   
   if((env->head)==NULL) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
   
   if(env->head->item->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err=2;  
     return;  
   }  
   
   dur=env->head->item->content.i;  
   toss(env);  
   
   usleep(dur);  
 };  
   
 extern void copying(environment *env){  
   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 1922  of preserving the free status of all der Line 1327  of preserving the free status of all der
1327  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
1328  }  }
1329    
1330  extern void warranty(environment *env){  extern void warranty(environment *env)
1331    {
1332    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
1333  \n\  \n\
1334    11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\    11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\
# Line 1946  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 || env->head->next==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;
     return;  
   }  
     
   if(env->head->item->type==integer  
      && env->head->next->item->type==integer) {  
     a=env->head->item->content.i;  
     toss(env); if(env->err) return;  
     b=env->head->item->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b*a);  
   
     return;  
   }  
   
   if(env->head->item->type==tfloat  
      && env->head->next->item->type==tfloat) {  
     fa= env->head->item->content.f;  
     toss(env); if(env->err) return;  
     fb= env->head->item->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb*fa);  
       
1365      return;      return;
1366    }    }
1367    
1368    if(env->head->item->type==tfloat    if(CAR(env->head)->type!=tcons) {
1369       && env->head->next->item->type==integer) {      printerr("Bad Argument Type");
1370      fa= env->head->item->content.f;      env->err= 2;
     toss(env); if(env->err) return;  
     b= env->head->item->content.i;  
     toss(env); if(env->err) return;  
     push_float(env, b*fa);  
       
1371      return;      return;
1372    }    }
1373    
1374    if(env->head->item->type==integer    key=CAR(CDR(env->head));
1375       && env->head->next->item->type==tfloat) {    item=CAR(env->head);
     a= env->head->item->content.i;  
     toss(env); if(env->err) return;  
     fb= env->head->item->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 || env->head->next==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(env->head->item->type==integer  
      && env->head->next->item->type==integer) {  
     a=env->head->item->content.i;  
     toss(env); if(env->err) return;  
     b=env->head->item->content.i;  
1403      toss(env); if(env->err) return;      toss(env); if(env->err) return;
     push_float(env, b/a);  
1404    
1405      return;      if(item->type!=tcons) {
1406    }        printerr("Bad Argument Type");
1407          env->err= 2;
1408    if(env->head->item->type==tfloat        return;
1409       && env->head->next->item->type==tfloat) {      }
     fa= env->head->item->content.f;  
     toss(env); if(env->err) return;  
     fb= env->head->item->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb/fa);  
       
     return;  
   }  
1410    
1411    if(env->head->item->type==tfloat      item=CDR(item);
      && env->head->next->item->type==integer) {  
     fa= env->head->item->content.f;  
     toss(env); if(env->err) return;  
     b= env->head->item->content.i;  
     toss(env); if(env->err) return;  
     push_float(env, b/fa);  
       
     return;  
1412    }    }
1413    
1414    if(env->head->item->type==integer    if(item->type == tcons){      /* A match was found */
1415       && env->head->next->item->type==tfloat) {      push_val(env, CAR(item));
1416      a= env->head->item->content.i;    } else {
1417      toss(env); if(env->err) return;      push_int(env, 0);
     fb= env->head->item->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 || env->head->next==NULL) {  
1429      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1430      env->err= 1;      env->err= 1;
1431      return;      return;
1432    }    }
1433        
1434    if(env->head->item->type==integer    env->head= CDR(env->head); /* Remove the top stack item */
      && env->head->next->item->type==integer) {  
     a= env->head->item->content.i;  
     toss(env); if(env->err) return;  
     b= env->head->item->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 || env->head->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->item->type==integer  
      && env->head->next->item->type==integer) {  
     a= env->head->item->content.i;  
     toss(env); if(env->err) return;  
     b= env->head->item->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.94  
changed lines
  Added in v.1.126
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26