/[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.129 by masse, Mon Aug 4 14:13:16 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.func);
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", CAR(env->gc_ref->item),
195                 CDR(env->gc_ref->item));
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.string)+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.string= malloc(length);
304    strcpy(new_value->content.ptr, in_string);    assert(new_value != NULL);
305      env->gc_count += length;
306      strcpy(new_value->content.string, in_string);
307    new_value->type= string;    new_value->type= string;
308    
309    push_val(env, new_value);    push_val(env, new_value);
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= mangle_str(CAR(env->head)->content.string);
350    
351    toss(env);    toss(env);
352    if(env->err) return;    if(env->err) return;
# Line 342  void push_sym(environment *env, const ch Line 370  void push_sym(environment *env, const ch
370    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
371    
372    new_value= new_val(env);    new_value= new_val(env);
373    protect(env, new_value);    protect(new_value);
374    new_fvalue= new_val(env);    new_fvalue= new_val(env);
375    protect(env, new_fvalue);    protect(new_fvalue);
376    
377    /* The new value is a symbol */    /* The new value is a symbol */
378    new_value->type= symb;    new_value->type= symb;
# Line 357  void push_sym(environment *env, const ch Line 385  void push_sym(environment *env, const ch
385    
386      /* Create a new symbol */      /* Create a new symbol */
387      (*new_symbol)= malloc(sizeof(symbol));      (*new_symbol)= malloc(sizeof(symbol));
388        assert((*new_symbol) != NULL);
389      (*new_symbol)->val= NULL;   /* undefined value */      (*new_symbol)->val= NULL;   /* undefined value */
390      (*new_symbol)->next= NULL;      (*new_symbol)->next= NULL;
391      (*new_symbol)->id= malloc(strlen(in_string)+1);      (*new_symbol)->id= malloc(strlen(in_string)+1);
392        assert((*new_symbol)->id != NULL);
393      strcpy((*new_symbol)->id, in_string);      strcpy((*new_symbol)->id, in_string);
394    
395      /* Intern the new symbol in the hash table */      /* Intern the new symbol in the hash table */
# Line 372  void push_sym(environment *env, const ch Line 402  void push_sym(environment *env, const ch
402    
403      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
404      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
405      free(mangled);  
406      dlerr= dlerror();      dlerr= dlerror();
407      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
408        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
409        dlerr= dlerror();        dlerr= dlerror();
410      }      }
411    
412      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
413        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
414        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.func= funcptr; /* Store function pointer */
415        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
416                                           function value */                                           function value */
417      }      }
418    
419        free(mangled);
420    }    }
421    
422    push_val(env, new_value);    push_val(env, new_value);
423    unprotect(env); unprotect(env);    unprotect(new_value); unprotect(new_fvalue);
424  }  }
425    
426  /* Print newline. */  /* Print a value */
427  extern void nl()  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
428  {  {
429    printf("\n");    stackitem *titem, *tstack;
430  }    int depth;
   
 /* Gets the type of a value */  
 extern void type(environment *env){  
   int typenum;  
431    
432    if((env->head)==NULL) {    switch(val->type) {
433      printerr("Too Few Arguments");    case empty:
434      env->err=1;      if(fprintf(stream, "[]") < 0){
435      return;        perror("print_val");
436    }        env->err= 5;
437    typenum=env->head->item->type;        return;
438    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");  
439      break;      break;
   }  
 }      
   
 /* Prints the top element of the stack. */  
 void print_h(stackitem *stack_head, int noquote)  
 {  
   switch(stack_head->item->type) {  
440    case integer:    case integer:
441      printf("%d", stack_head->item->content.i);      if(fprintf(stream, "%d", val->content.i) < 0){
442          perror("print_val");
443          env->err= 5;
444          return;
445        }
446      break;      break;
447    case tfloat:    case tfloat:
448      printf("%f", stack_head->item->content.f);      if(fprintf(stream, "%f", val->content.f) < 0){
449          perror("print_val");
450          env->err= 5;
451          return;
452        }
453      break;      break;
454    case string:    case string:
455      if(noquote)      if(noquote){
456        printf("%s", (char*)stack_head->item->content.ptr);        if(fprintf(stream, "%s", val->content.string) < 0){
457      else          perror("print_val");
458        printf("\"%s\"", (char*)stack_head->item->content.ptr);          env->err= 5;
459            return;
460          }
461        } else {                    /* quote */
462          if(fprintf(stream, "\"%s\"", val->content.string) < 0){
463            perror("print_val");
464            env->err= 5;
465            return;
466          }
467        }
468      break;      break;
469    case symb:    case symb:
470      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      if(fprintf(stream, "%s", val->content.sym->id) < 0){
471          perror("print_val");
472          env->err= 5;
473          return;
474        }
475      break;      break;
476    case func:    case func:
477      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      if(fprintf(stream, "#<function %p>", val->content.func) < 0){
478          perror("print_val");
479          env->err= 5;
480          return;
481        }
482      break;      break;
483    case list:    case port:
484      /* A list is just a stack, so make stack_head point to it */      if(fprintf(stream, "#<port %p>", val->content.p) < 0){
485      stack_head=(stackitem *)(stack_head->item->content.ptr);        perror("print_val");
486      printf("[ ");        env->err= 5;
487      while(stack_head != NULL) {        return;
       print_h(stack_head, noquote);  
       printf(" ");  
       stack_head=stack_head->next;  
488      }      }
     printf("]");  
489      break;      break;
490    }    case tcons:
491  }      if(fprintf(stream, "[ ") < 0){
492          perror("print_val");
493  extern void print_(environment *env) {        env->err= 5;
494    if(env->head==NULL) {        return;
495      printerr("Too Few Arguments");      }
496      env->err=1;      tstack= stack;
497      return;      do {
498    }        titem=malloc(sizeof(stackitem));
499    print_h(env->head, 0);        assert(titem != NULL);
500    nl();        titem->item=val;
501  }        titem->next=tstack;
502          tstack=titem;             /* Put it on the stack */
503  /* Prints the top element of the stack and then discards it. */        /* Search a stack of values being printed to see if we are already
504  extern void print(environment *env)           printing this value */
505  {        titem=tstack;
506    print_(env);        depth=0;
507    if(env->err) return;        while(titem != NULL && titem->item != CAR(val)){
508    toss(env);          titem=titem->next;
509  }          depth++;
510          }
511  extern void princ_(environment *env) {        if(titem != NULL){        /* If we found it on the stack, */
512    if(env->head==NULL) {          if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
513      printerr("Too Few Arguments");            perror("print_val");
514      env->err=1;            env->err= 5;
515      return;            free(titem);
516    }            return;
517    print_h(env->head, 1);          }
518  }        } else {
519            print_val(env, CAR(val), noquote, tstack, stream);
520          }
521          val= CDR(val);
522          switch(val->type){
523          case empty:
524            break;
525          case tcons:
526            /* Search a stack of values being printed to see if we are already
527               printing this value */
528            titem=tstack;
529            depth=0;
530            while(titem != NULL && titem->item != val){
531              titem=titem->next;
532              depth++;
533            }
534            if(titem != NULL){      /* If we found it on the stack, */
535              if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
536                perror("print_val");
537                env->err= 5;
538                goto printval_end;
539              }
540            } else {
541              if(fprintf(stream, " ") < 0){
542                perror("print_val");
543                env->err= 5;
544                goto printval_end;
545              }
546            }
547            break;
548          default:
549            if(fprintf(stream, " . ") < 0){ /* Improper list */
550              perror("print_val");
551              env->err= 5;
552              goto printval_end;
553            }
554            print_val(env, val, noquote, tstack, stream);
555          }
556        } while(val->type == tcons && titem == NULL);
557    
558  /* Prints the top element of the stack and then discards it. */    printval_end:
 extern void princ(environment *env)  
 {  
   princ_(env);  
   if(env->err) return;  
   toss(env);  
 }  
559    
560  /* Only to be called by function printstack. */      titem=tstack;
561  void print_st(stackitem *stack_head, long counter)      while(titem != stack){
562  {        tstack=titem->next;
563    if(stack_head->next != NULL)        free(titem);
564      print_st(stack_head->next, counter+1);        titem=tstack;
565    printf("%ld: ", counter);      }
   print_h(stack_head, 0);  
   nl();  
 }  
566    
567  /* Prints the stack. */      if(! (env->err)){
568  extern void printstack(environment *env)        if(fprintf(stream, " ]") < 0){
569  {          perror("print_val");
570    if(env->head == NULL) {          env->err= 5;
571      printf("Stack Empty\n");        }
572      return;      }
573        break;
574    }    }
   print_st(env->head, 1);  
575  }  }
576    
577  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
578  extern void swap(environment *env)  extern void swap(environment *env)
579  {  {
580    stackitem *temp= env->head;    value *temp= env->head;
581        
582    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
583      printerr("Too Few Arguments");      printerr("Too Few Arguments");
584      env->err=1;      env->err=1;
585      return;      return;
586    }    }
587    
588    env->head= env->head->next;    env->head= CDR(env->head);
589    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
590    env->head->next= temp;    CDR(env->head)= temp;
591  }  }
592    
 /* 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;  
 }  
   
593  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
594  extern void rcl(environment *env)  extern void rcl(environment *env)
595  {  {
596    value *val;    value *val;
597    
598    if(env->head == NULL) {    if(env->head->type==empty) {
599      printerr("Too Few Arguments");      printerr("Too Few Arguments");
600      env->err=1;      env->err= 1;
601      return;      return;
602    }    }
603    
604    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
605      printerr("Bad Argument Type");      printerr("Bad Argument Type");
606      env->err=2;      env->err= 2;
607      return;      return;
608    }    }
609    
610    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
611    if(val == NULL){    if(val == NULL){
612      printerr("Unbound Variable");      printerr("Unbound Variable");
613      env->err=3;      env->err= 3;
614      return;      return;
615    }    }
616    protect(env, val);    push_val(env, val);           /* Return the symbol's bound value */
617    toss(env);            /* toss the symbol */    swap(env);
618      if(env->err) return;
619      toss(env);                    /* toss the symbol */
620    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(env);  
621  }  }
622    
623    
624  /* If the top element is a symbol, determine if it's bound to a  /* If the top element is a symbol, determine if it's bound to a
625     function value, and if it is, toss the symbol and execute the     function value, and if it is, toss the symbol and execute the
626     function. */     function. */
# Line 589  extern void eval(environment *env) Line 628  extern void eval(environment *env)
628  {  {
629    funcp in_func;    funcp in_func;
630    value* temp_val;    value* temp_val;
631    stackitem* iterator;    value* iterator;
632    
633   eval_start:   eval_start:
634    
635    if(env->head==NULL) {    gc_maybe(env);
636    
637      if(env->head->type==empty) {
638      printerr("Too Few Arguments");      printerr("Too Few Arguments");
639      env->err=1;      env->err= 1;
640      return;      return;
641    }    }
642    
643    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
644      /* if it's a symbol */      /* if it's a symbol */
645    case symb:    case symb:
646      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
647      if(env->err) return;      if(env->err) return;
648      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
649        goto eval_start;        goto eval_start;
650      }      }
651      return;      return;
652    
653      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
654    case func:    case func:
655      in_func= (funcp)(env->head->item->content.ptr);      in_func= CAR(env->head)->content.func;
656      toss(env);      toss(env);
657      if(env->err) return;      if(env->err) return;
658      return in_func(env);      return in_func(env);
659    
660      /* If it's a list */      /* If it's a list */
661    case list:    case tcons:
662      temp_val= env->head->item;      temp_val= CAR(env->head);
663      protect(env, temp_val);      protect(temp_val);
664    
665      toss(env); if(env->err) return;      toss(env); if(env->err) return;
666      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
667            
668      while(iterator!=NULL) {      while(iterator->type != empty) {
669        push_val(env, iterator->item);        push_val(env, CAR(iterator));
670                
671        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
672          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
673          toss(env);          toss(env);
674          if(env->err) return;          if(env->err) return;
675                    
676          if(iterator->next == NULL){          if(CDR(iterator)->type == empty){
677            goto eval_start;            goto eval_start;
678          }          }
679          eval(env);          eval(env);
680          if(env->err) return;          if(env->err) return;
681        }        }
682        iterator= iterator->next;        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
683            iterator= CDR(iterator);
684          else {
685            printerr("Bad Argument Type"); /* Improper list */
686            env->err= 2;
687            return;
688          }
689      }      }
690      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;  
     return;  
   }  
   
   if(env->head->item->type!=list) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
691      return;      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);  
   
   if(iterator==NULL  
      || (iterator->item->type==symb  
      && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {  
     temp= NULL;  
     toss(env);  
   } else {  
     /* 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);  
692    
693    unprotect(env);    case empty:
694  }      toss(env);
695      case integer:
696  /* Relocate elements of the list on the stack. */    case tfloat:
697  extern void expand(environment *env)    case string:
698  {    case port:
   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;  
699      return;      return;
700    }    }
   
   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! */  
   
701  }  }
702    
703  /* Compares two elements by reference. */  /* List all defined words */
704  extern void eq(environment *env)  extern void words(environment *env)
705  {  {
706    void *left, *right;    symbol *temp;
707    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);  
708        
709    toss(env); toss(env);    for(i= 0; i<HASHTBLSIZE; i++) {
710    push_int(env, result);      temp= env->symbols[i];
711  }      while(temp!=NULL) {
712    #ifdef DEBUG
713  /* Negates the top element on the stack. */        if (temp->val != NULL && temp->val->gc.flag.protect)
714  extern void not(environment *env)          printf("(protected) ");
715  {  #endif /* DEBUG */
716    int val;        printf("%s ", temp->id);
717          temp= temp->next;
718    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;  
719    }    }
   
   val= env->head->item->content.i;  
   toss(env);  
   push_int(env, !val);  
720  }  }
721    
 /* 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 || 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);  
 }  
   
722  /* Quit stack. */  /* Quit stack. */
723  extern void quit(environment *env)  extern void quit(environment *env)
724  {  {
725    long i;    int i;
726    
727    clear(env);    while(env->head->type != empty)
728        toss(env);
729    
730    if (env->err) return;    if (env->err) return;
731    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
# Line 848  extern void quit(environment *env) Line 736  extern void quit(environment *env)
736    }    }
737    
738    env->gc_limit= 0;    env->gc_limit= 0;
739    gc_init(env);    gc_maybe(env);
740    
741      words(env);
742    
743    if(env->free_string!=NULL)    if(env->free_string!=NULL)
744      free(env->free_string);      free(env->free_string);
745        
746    #ifdef __linux__
747    muntrace();    muntrace();
748    #endif
749    
750    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
751  }  }
752    
 /* Clear stack */  
 extern void clear(environment *env)  
 {  
   while(env->head!=NULL)  
     toss(env);  
 }  
   
 /* List all defined words */  
 extern void words(environment *env)  
 {  
   symbol *temp;  
   int i;  
     
   for(i= 0; i<HASHTBLSIZE; i++) {  
     temp= env->symbols[i];  
     while(temp!=NULL) {  
       printf("%s\n", temp->id);  
       temp= temp->next;  
     }  
   }  
 }  
   
753  /* Internal forget function */  /* Internal forget function */
754  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
755    {
756    symbol *temp;    symbol *temp;
757    
758    temp= *hash_entry;    temp= *hash_entry;
# Line 891  void forget_sym(symbol **hash_entry) { Line 762  void forget_sym(symbol **hash_entry) {
762    free(temp);    free(temp);
763  }  }
764    
765  /* Forgets a symbol (remove it from the hash table) */  /* Only to be called by itself function printstack. */
766  extern void forget(environment *env)  void print_st(environment *env, value *stack_head, long counter)
767  {  {
768    char* sym_id;    if(CDR(stack_head)->type != empty)
769    stackitem *stack_head= env->head;      print_st(env, CDR(stack_head), counter+1);
770      printf("%ld: ", counter);
771      print_val(env, CAR(stack_head), 0, NULL, stdout);
772      printf("\n");
773    }
774    
775    if(stack_head==NULL) {  /* Prints the stack. */
776      printerr("Too Few Arguments");  extern void printstack(environment *env)
777      env->err=1;  {
778      return;    if(env->head->type == empty) {
779    }      printf("Stack Empty\n");
     
   if(stack_head->item->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err=2;  
780      return;      return;
781    }    }
782    
783    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);  
784  }  }
785    
786  int main(int argc, char **argv)  int main(int argc, char **argv)
# Line 926  int main(int argc, char **argv) Line 789  int main(int argc, char **argv)
789    
790    int c;                        /* getopt option character */    int c;                        /* getopt option character */
791    
792    #ifdef __linux__
793    mtrace();    mtrace();
794    #endif
795    
796    init_env(&myenv);    init_env(&myenv);
797    
# Line 940  int main(int argc, char **argv) Line 805  int main(int argc, char **argv)
805          break;          break;
806        case '?':        case '?':
807          fprintf (stderr,          fprintf (stderr,
808                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
809                   optopt);                   optopt);
810          return EX_USAGE;          return EX_USAGE;
811        default:        default:
# Line 959  int main(int argc, char **argv) Line 824  int main(int argc, char **argv)
824    if(myenv.interactive) {    if(myenv.interactive) {
825      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
826  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
827  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
828  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
829  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
830    }    }
831    
832    while(1) {    while(1) {
# Line 969  under certain conditions; type `copying; Line 834  under certain conditions; type `copying;
834        if (myenv.interactive) {        if (myenv.interactive) {
835          if(myenv.err) {          if(myenv.err) {
836            printf("(error %d)\n", myenv.err);            printf("(error %d)\n", myenv.err);
837              myenv.err= 0;
838          }          }
839          nl();          printf("\n");
840          printstack(&myenv);          printstack(&myenv);
841          printf("> ");          printf("> ");
842        }        }
843        myenv.err=0;        myenv.err=0;
844      }      }
845      sx_72656164(&myenv);      readstream(&myenv, myenv.inputstream);
846      if (myenv.err==4) {      if (myenv.err) {            /* EOF or other error */
847        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
848      } else if(myenv.head!=NULL        quit(&myenv);
849                && myenv.head->item->type==symb      } else if(myenv.head->type!=empty
850                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->type==symb
851        toss(&myenv);             /* No error check in main */                && CAR(myenv.head)->content.sym->id[0] == ';') {
852          toss(&myenv); if(myenv.err) continue;
853        eval(&myenv);        eval(&myenv);
854        } else {
855          gc_maybe(&myenv);
856      }      }
     gc_init(&myenv);  
857    }    }
858    quit(&myenv);    quit(&myenv);
859    return EXIT_FAILURE;    return EXIT_FAILURE;
860  }  }
861    
 /* "+" */  
 extern void sx_2b(environment *env) {  
   int a, b;  
   float fa, fb;  
   size_t len;  
   char* new_string;  
   value *a_val, *b_val;  
   
   if((env->head)==NULL || 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);  
 }  
   
862  /* Return copy of a value */  /* Return copy of a value */
863  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
864    stackitem *old_item, *new_item, *prev_item;  {
865    value *new_value;    value *new_value;
866    
867    protect(env, old_value);    if(old_value==NULL)
868        return NULL;
869    
870    new_value= new_val(env);    new_value= new_val(env);
   protect(env, new_value);  
871    new_value->type= old_value->type;    new_value->type= old_value->type;
872    
873    switch(old_value->type){    switch(old_value->type){
# Line 1222  value *copy_val(environment *env, value Line 875  value *copy_val(environment *env, value
875    case integer:    case integer:
876    case func:    case func:
877    case symb:    case symb:
878      case empty:
879      case port:
880      new_value->content= old_value->content;      new_value->content= old_value->content;
881      break;      break;
882    case string:    case string:
883      (char *)(new_value->content.ptr)=      new_value->content.string= strdup(old_value->content.string);
       strdup((char *)(old_value->content.ptr));  
884      break;      break;
885    case list:    case tcons:
     new_value->content.ptr= NULL;  
886    
887      prev_item= NULL;      new_value->content.c= malloc(sizeof(pair));
888      old_item= (stackitem*)(old_value->content.ptr);      assert(new_value->content.c!=NULL);
889        env->gc_count += sizeof(pair);
890    
891      while(old_item != NULL) {   /* While list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
892        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;  
     }      
893      break;      break;
894    }    }
895    
   unprotect(env); unprotect(env);  
   
896    return new_value;    return new_value;
897  }  }
898    
899  /* "dup"; duplicates an item on the stack */  /* read a line from a stream; used by readline */
900  extern void sx_647570(environment *env) {  void readlinestream(environment *env, FILE *stream)
901    if((env->head)==NULL) {  {
902      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;  
   }  
903    
904    loop= env->head->item;    if(fgets(in_string, 100, stream)==NULL) {
905    protect(env, loop);      push_cstring(env, "");
906    toss(env); if(env->err) return;      if (! feof(stream)){
907          perror("readline");
908    test= env->head->item;        env->err= 5;
   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);  
909      }      }
910        } else {
911    } while(truth);      push_cstring(env, in_string);
912      }
   unprotect(env); unprotect(env);  
913  }  }
914    
915    /* Reverse (flip) a list */
916    extern void rev(environment *env)
917    {
918      value *old_head, *new_head, *item;
919    
920  /* "for"; for-loop */    if(env->head->type==empty) {
 extern void sx_666f72(environment *env) {  
   value *loop;  
   int foo1, foo2;  
   
   if(env->head==NULL || env->head->next==NULL  
      || env->head->next->next==NULL) {  
921      printerr("Too Few Arguments");      printerr("Too Few Arguments");
922      env->err= 1;      env->err= 1;
923      return;      return;
924    }    }
925    
926    if(env->head->next->item->type!=integer    if(CAR(env->head)->type==empty)
927       || env->head->next->next->item->type!=integer) {      return;                     /* Don't reverse an empty list */
928    
929      if(CAR(env->head)->type!=tcons) {
930      printerr("Bad Argument Type");      printerr("Bad Argument Type");
931      env->err= 2;      env->err= 2;
932      return;      return;
933    }    }
934    
935    loop= env->head->item;    old_head= CAR(env->head);
936    protect(env, loop);    new_head= new_val(env);
937    toss(env); if(env->err) return;    while(old_head->type != empty) {
938        item= old_head;
939    foo2= env->head->item->content.i;      old_head= CDR(old_head);
940    toss(env); if(env->err) return;      CDR(item)= new_head;
941        new_head= item;
   foo1= env->head->item->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--;  
     }  
942    }    }
943    unprotect(env);    CAR(env->head)= new_head;
944  }  }
945    
946  /* Variant of for-loop */  /* Make a list. */
947  extern void foreach(environment *env) {  extern void pack(environment *env)
948      {
949    value *loop, *foo;    value *iterator, *temp, *ending;
   stackitem *iterator;  
     
   if((env->head)==NULL || env->head->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->next->item->type != list) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   loop= env->head->item;  
   protect(env, loop);  
   toss(env); if(env->err) return;  
   
   foo= env->head->item;  
   protect(env, foo);  
   toss(env); if(env->err) return;  
   
   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;  
   }  
950    
951    if(env->head->item->type!=integer    ending=new_val(env);
      || env->head->next->item->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err=2;  
     return;  
   }  
952    
953    ending= env->head->item->content.i;    iterator= env->head;
954    toss(env); if(env->err) return;    if(iterator->type == empty
955    start= env->head->item->content.i;       || (CAR(iterator)->type==symb
956    toss(env); if(env->err) return;       && CAR(iterator)->content.sym->id[0]=='[')) {
957        temp= ending;
958    temp_head= env->head;      toss(env);
   env->head= NULL;  
   
   if(ending>=start) {  
     for(i= ending; i>=start; i--)  
       push_int(env, i);  
959    } else {    } else {
960      for(i= ending; i<=start; i++)      /* Search for first delimiter */
961        push_int(env, i);      while(CDR(iterator)->type != empty
962    }            && (CAR(CDR(iterator))->type!=symb
963               || CAR(CDR(iterator))->content.sym->id[0]!='['))
964    temp_val= new_val(env);        iterator= CDR(iterator);
965    protect(env, temp_val);      
966        /* Extract list */
967    temp_val->content.ptr= env->head;      temp= env->head;
968    temp_val->type= list;      env->head= CDR(iterator);
969    env->head= temp_head;      CDR(iterator)= ending;
   push_val(env, temp_val);  
970    
971    unprotect(env);      if(env->head->type != empty)
972  }        toss(env);
973      }
974    
975  /* Read a string */    /* Push list */
 extern void readline(environment *env) {  
   char in_string[101];  
976    
977    if(fgets(in_string, 100, env->inputstream)==NULL)    push_val(env, temp);
978      push_cstring(env, "");    rev(env);
   else  
     push_cstring(env, in_string);  
979  }  }
980    
981  /* "read"; Read a value and place on stack */  /* read from a stream; used by "read" and "readport" */
982  extern void sx_72656164(environment *env) {  void readstream(environment *env, FILE *stream)
983    {
984    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
985    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
986    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1532  extern void sx_72656164(environment *env Line 994  extern void sx_72656164(environment *env
994    int count= -1;    int count= -1;
995    float ftemp;    float ftemp;
996    static int depth= 0;    static int depth= 0;
997    char *match, *ctemp;    char *match;
998    size_t inlength;    size_t inlength;
999    
1000    if(env->in_string==NULL) {    if(env->in_string==NULL) {
1001      if(depth > 0 && env->interactive) {      if(depth > 0 && env->interactive) {
1002        printf("]> ");        printf("]> ");
1003      }      }
1004      readline(env); if(env->err) return;      readlinestream(env, env->inputstream);
1005        if(env->err) return;
1006    
1007      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if((CAR(env->head)->content.string)[0]=='\0'){
1008        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1009        return;        return;
1010      }      }
1011            
1012      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.string)+1);
1013        assert(env->in_string != NULL);
1014      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1015      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.string);
1016      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1017    }    }
1018        
1019    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1020    match= malloc(inlength);    match= malloc(inlength);
1021      assert(match != NULL);
1022    
1023    if(sscanf(env->in_string, blankform, &readlength) != EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1024       && readlength != -1) {       && readlength != -1) {
# Line 1566  extern void sx_72656164(environment *env Line 1031  extern void sx_72656164(environment *env
1031      } else {      } else {
1032        push_float(env, ftemp);        push_float(env, ftemp);
1033      }      }
1034      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1035                && readlength != -1) {
1036        push_cstring(env, "");
1037    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1038              && readlength != -1) {              && readlength != -1) {
1039      push_cstring(env, match);      push_cstring(env, match);
# Line 1594  extern void sx_72656164(environment *env Line 1062  extern void sx_72656164(environment *env
1062    free(match);    free(match);
1063    
1064    if(depth)    if(depth)
1065      return sx_72656164(env);      return readstream(env, env->inputstream);
1066  }  }
1067    
1068  extern void beep(environment *env) {  extern void copying(environment *env)
1069    {
1070    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\  
1071                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1072  \n\  \n\
1073   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 1922  of preserving the free status of all der Line 1325  of preserving the free status of all der
1325  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
1326  }  }
1327    
1328  extern void warranty(environment *env){  extern void warranty(environment *env)
1329    {
1330    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
1331  \n\  \n\
1332    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 1350  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER
1350  POSSIBILITY OF SUCH DAMAGES.\n");  POSSIBILITY OF SUCH DAMAGES.\n");
1351  }  }
1352    
1353  /* "*" */  /* Discard the top element of the stack. */
1354  extern void sx_2a(environment *env)  extern void toss(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_2f(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_float(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;  
 }  
   
 /* "mod" */  
 extern void mod(environment *env)  
1355  {  {
1356    int a, b;    if(env->head->type==empty) {
   
   if((env->head)==NULL || env->head->next==NULL) {  
1357      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1358      env->err= 1;      env->err= 1;
1359      return;      return;
1360    }    }
1361        
1362    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;  
1363  }  }
1364    
 /* "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.129
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26