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