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

Diff of /stack/stack.c

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

revision 1.64 by teddy, Fri Feb 8 16:33:14 2002 UTC revision 1.126 by masse, Mon Aug 4 11:22:02 2003 UTC
# Line 1  Line 1 
1  /* printf, sscanf, fgets, fprintf */  /* -*- coding: utf-8; -*- */
2  #include <stdio.h>  /*
3  /* exit, EXIT_SUCCESS, malloc, free */      stack - an interactive interpreter for a stack-based language
4  #include <stdlib.h>      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn
5  /* NULL */  
6  #include <stddef.h>      This program is free software; you can redistribute it and/or modify
7  /* dlopen, dlsym, dlerror */      it under the terms of the GNU General Public License as published by
8  #include <dlfcn.h>      the Free Software Foundation; either version 2 of the License, or
9  /* strcmp, strcpy, strlen, strcat, strdup */      (at your option) any later version.
10  #include <string.h>  
11        This program is distributed in the hope that it will be useful,
12  #define HASHTBLSIZE 65536      but WITHOUT ANY WARRANTY; without even the implied warranty of
13        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14  /* First, define some types. */      GNU General Public License for more details.
15    
16  /* A value of some type */      You should have received a copy of the GNU General Public License
17  typedef struct {      along with this program; if not, write to the Free Software
18    enum {      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
19      integer,  
20      string,      Authors: Mats Alritzson <masse@fukt.bth.se>
21      func,                       /* Function pointer */               Teddy Hogeborn <teddy@fukt.bth.se>
22      symb,  */
23      list  
24    } type;                       /* Type of stack element */  #include "stack.h"
   
   union {  
     void *ptr;                  /* Pointer to the content */  
     int val;                    /* ...or an integer */  
   } content;                    /* Stores a pointer or an integer */  
   
   int refcount;                 /* Reference counter */  
   
 } value;  
   
 /* A symbol with a name and possible value */  
 /* (These do not need reference counters, they are kept unique by  
    hashing.) */  
 typedef struct symbol_struct {  
   char *id;                     /* Symbol name */  
   value *val;                   /* The value (if any) bound to it */  
   struct symbol_struct *next;   /* In case of hashing conflicts, a */  
 } symbol;                       /* symbol is a kind of stack item. */  
   
 /* A type for a hash table for symbols */  
 typedef symbol *hashtbl[HASHTBLSIZE]; /* Hash table declaration */  
   
 /* An item (value) on a stack */  
 typedef struct stackitem_struct  
 {  
   value *item;                  /* The value on the stack */  
                                 /* (This is never NULL) */  
   struct stackitem_struct *next; /* Next item */  
 } stackitem;  
   
 /* An environment; gives access to the stack and a hash table of  
    defined symbols */  
 typedef struct {  
   stackitem *head;              /* Head of the stack */  
   hashtbl symbols;              /* Hash table of all variable bindings */  
   int err;                      /* Error flag */  
   int non_eval_flag;  
 } environment;  
   
 /* A type for pointers to external functions */  
 typedef void (*funcp)(environment *); /* funcp is a pointer to a void  
                                          function (environment *) */  
25    
26  /* Initialize a newly created environment */  /* Initialize a newly created environment */
27  void init_env(environment *env)  void init_env(environment *env)
28  {  {
29    int i;    int i;
30    
31    env->err= 0;    env->gc_limit= 400000;
32    env->non_eval_flag= 0;    env->gc_count= 0;
33      env->gc_ref= NULL;
34    
35      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;
39      env->in_string= NULL;
40      env->free_string= NULL;
41      env->inputstream= stdin;
42      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);  
 }  
   
 /* Throw away a value */  
 void free_val(value *val){  
   stackitem *item, *temp;  
   
   val->refcount--;              /* Decrease the reference count */  
   if(val->refcount == 0){  
     switch (val->type){         /* and free the contents if necessary */  
     case string:  
       free(val->content.ptr);  
       break;  
     case list:                  /* lists needs to be freed recursively */  
       item=val->content.ptr;  
       while(item != NULL) {     /* for all stack items */  
         free_val(item->item);   /* free the value */  
         temp=item->next;        /* save next ptr */  
         free(item);             /* free the stackitem */  
         item=temp;              /* go to next stackitem */  
       }  
       free(val);                /* Free the actual list value */  
       break;  
     case integer:  
     case func:  
     case symb:  
       break;  
     }  
   }  
 }  
   
 /* 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;  
   }  
     
   free_val(env->head->item);    /* Free the value */  
   env->head= env->head->next;   /* Remove the top stack item */  
   free(temp);                   /* Free the old top stack item */  
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 153  symbol **hash(hashtbl in_hashtbl, const Line 76  symbol **hash(hashtbl in_hashtbl, const
76    }    }
77  }  }
78    
79  /* Generic push function. */  /* Create new value */
80  void push(stackitem** stack_head, stackitem* in_item)  value* new_val(environment *env)
81    {
82      value *nval= malloc(sizeof(value));
83      stackitem *nitem= malloc(sizeof(stackitem));
84    
85      assert(nval != NULL);
86      assert(nitem != NULL);
87    
88      nval->content.ptr= NULL;
89      nval->type= empty;
90    
91      nitem->item= nval;
92      nitem->next= env->gc_ref;
93    
94      env->gc_ref= nitem;
95    
96      env->gc_count += sizeof(value);
97      nval->gc.flag.mark= 0;
98      nval->gc.flag.protect= 0;
99    
100      return nval;
101    }
102    
103    
104    /* Mark values recursively.
105       Marked values are not collected by the GC. */
106    inline void gc_mark(value *val)
107  {  {
108    in_item->next= *stack_head;    if(val==NULL || val->gc.flag.mark)
109    *stack_head= in_item;      return;
110    
111      val->gc.flag.mark= 1;
112    
113      if(val->type==tcons) {
114        gc_mark(CAR(val));
115        gc_mark(CDR(val));
116      }
117    }
118    
119    
120    /* Start GC */
121    extern void gc_init(environment *env)
122    {
123      stackitem *new_head= NULL, *titem;
124      symbol *tsymb;
125      int i;
126    
127      if(env->interactive)
128        printf("Garbage collecting.");
129    
130      /* Mark values on stack */
131      gc_mark(env->head);
132    
133      if(env->interactive)
134        printf(".");
135    
136    
137      /* Mark values in hashtable */
138      for(i= 0; i<HASHTBLSIZE; i++)
139        for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
140          if (tsymb->val != NULL)
141            gc_mark(tsymb->val);
142    
143    
144      if(env->interactive)
145        printf(".");
146    
147      env->gc_count= 0;
148    
149      while(env->gc_ref!=NULL) {    /* Sweep unused values */
150    
151        if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
152    
153          /* Remove content */
154          switch(env->gc_ref->item->type){
155          case string:
156            free(env->gc_ref->item->content.ptr);
157            break;
158          case tcons:
159            free(env->gc_ref->item->content.c);
160            break;
161          case port:
162          case empty:
163          case integer:
164          case tfloat:
165          case func:
166          case symb:
167            /* Symbol strings are freed when walking the hash table */
168            break;
169          }
170    
171          free(env->gc_ref->item);  /* Remove from gc_ref */
172          titem= env->gc_ref->next;
173          free(env->gc_ref);        /* Remove value */
174          env->gc_ref= titem;
175          continue;
176        }
177    #ifdef DEBUG
178        printf("Kept value (%p)", env->gc_ref->item);
179        if(env->gc_ref->item->gc.flag.mark)
180          printf(" (marked)");
181        if(env->gc_ref->item->gc.flag.protect)
182          printf(" (protected)");
183        switch(env->gc_ref->item->type){
184        case integer:
185          printf(" integer: %d", env->gc_ref->item->content.i);
186          break;
187        case func:
188          printf(" func: %p", env->gc_ref->item->content.ptr);
189          break;
190        case symb:
191          printf(" symb: %s", env->gc_ref->item->content.sym->id);
192          break;
193        case tcons:
194          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
195                 env->gc_ref->item->content.c->cdr);
196          break;
197        default:
198          printf(" <unknown %d>", (env->gc_ref->item->type));
199        }
200        printf("\n");
201    #endif /* DEBUG */
202    
203        /* Keep values */    
204        env->gc_count += sizeof(value);
205        if(env->gc_ref->item->type==string)
206          env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
207        
208        titem= env->gc_ref->next;
209        env->gc_ref->next= new_head;
210        new_head= env->gc_ref;
211        new_head->item->gc.flag.mark= 0;
212        env->gc_ref= titem;
213      }
214    
215      if (env->gc_limit < env->gc_count*2)
216        env->gc_limit= env->gc_count*2;
217    
218      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    inline void gc_maybe(environment *env)
226    {
227      if(env->gc_count < env->gc_limit)
228        return;
229      else
230        return gc_init(env);
231    }
232    
233    /* Protect values from GC */
234    void protect(value *val)
235    {
236      if(val==NULL || val->gc.flag.protect)
237        return;
238    
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(stackitem **stack_head, 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    val->refcount++;    new_value->content.c= malloc(sizeof(pair));
267    push(stack_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(stackitem **stack_head, int in_val)  void push_int(environment *env, int in_val)
277  {  {
278    value *new_value= malloc(sizeof(value));    value *new_value= new_val(env);
   stackitem *new_item= malloc(sizeof(stackitem));  
   new_item->item= new_value;  
279        
280    new_value->content.val= in_val;    new_value->content.i= in_val;
281    new_value->type= integer;    new_value->type= integer;
   new_value->refcount=1;  
282    
283    push(stack_head, new_item);    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)
288    {
289      value *new_value= new_val(env);
290    
291      new_value->content.f= in_val;
292      new_value->type= tfloat;
293    
294      push_val(env, new_value);
295  }  }
296    
297  /* Copy a string onto the stack. */  /* Copy a string onto the stack. */
298  void push_cstring(stackitem **stack_head, const char *in_string)  void push_cstring(environment *env, const char *in_string)
299  {  {
300    value *new_value= malloc(sizeof(value));    value *new_value= new_val(env);
301    stackitem *new_item= malloc(sizeof(stackitem));    int length= strlen(in_string)+1;
   new_item->item=new_value;  
302    
303    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
304      assert(new_value != NULL);
305      env->gc_count += length;
306    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
307    new_value->type= string;    new_value->type= string;
   new_value->refcount=1;  
308    
309    push(stack_head, new_item);    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    char validchars[]  {
315      ="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'){
323      current[0]=validchars[(unsigned char)(old_string[0])/16];      current[0]= validchars[(unsigned char)(old_string[0])/16];
324      current[1]=validchars[(unsigned char)(old_string[0])%16];      current[1]= validchars[(unsigned char)(old_string[0])%16];
325      current+=2;      current+= 2;
326      old_string++;      old_string++;
327    }    }
328    current[0]='\0';    current[0]= '\0';
329    
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    value *new_value;  {
335    char *new_string;    char *new_string;
336    
337    if((env->head)==NULL) {    if(env->head->type==empty) {
338      printerr("Too Few Arguments");      printerr("Too Few Arguments");
339      env->err=1;      env->err= 1;
340      return;      return;
341    }    }
342    
343    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
344      printerr("Bad Argument Type");      printerr("Bad Argument Type");
345      env->err=2;      env->err= 2;
346      return;      return;
347    }    }
348    
349    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
350        mangle_str((const char *)(CAR(env->head)->content.ptr));
351    
352    toss(env);    toss(env);
353    if(env->err) return;    if(env->err) return;
354    
355    new_value= malloc(sizeof(value));    push_cstring(env, new_string);
   new_value->content.ptr= new_string;  
   new_value->type= string;  
   new_value->refcount=1;  
   
   push_val(&(env->head), new_value);  
356  }  }
357    
358  /* Push a symbol onto the stack. */  /* Push a symbol onto the stack. */
359  void push_sym(environment *env, const char *in_string)  void push_sym(environment *env, const char *in_string)
360  {  {
   stackitem *new_item;          /* The new stack item */  
   /* ...which will contain... */  
361    value *new_value;             /* A new symbol value */    value *new_value;             /* A new symbol value */
362    /* ...which might point to... */    /* ...which might point to... */
363    symbol **new_symbol;          /* (if needed) A new actual symbol */    symbol **new_symbol;          /* (if needed) A new actual symbol */
# Line 264  void push_sym(environment *env, const ch Line 370  void push_sym(environment *env, const ch
370    const char *dlerr;            /* Dynamic linker error */    const char *dlerr;            /* Dynamic linker error */
371    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
372    
373    /* Create a new stack item containing a new value */    new_value= new_val(env);
374    new_item= malloc(sizeof(stackitem));    protect(new_value);
375    new_value= malloc(sizeof(value));    new_fvalue= new_val(env);
376    new_item->item=new_value;    protect(new_fvalue);
377    
378    /* The new value is a symbol */    /* The new value is a symbol */
379    new_value->type= symb;    new_value->type= symb;
   new_value->refcount= 1;  
380    
381    /* Look up the symbol name in the hash table */    /* Look up the symbol name in the hash table */
382    new_symbol= hash(env->symbols, in_string);    new_symbol= hash(env->symbols, in_string);
# Line 281  void push_sym(environment *env, const ch Line 386  void push_sym(environment *env, const ch
386    
387      /* Create a new symbol */      /* Create a new symbol */
388      (*new_symbol)= malloc(sizeof(symbol));      (*new_symbol)= malloc(sizeof(symbol));
389        assert((*new_symbol) != NULL);
390      (*new_symbol)->val= NULL;   /* undefined value */      (*new_symbol)->val= NULL;   /* undefined value */
391      (*new_symbol)->next= NULL;      (*new_symbol)->next= NULL;
392      (*new_symbol)->id= malloc(strlen(in_string)+1);      (*new_symbol)->id= malloc(strlen(in_string)+1);
393        assert((*new_symbol)->id != NULL);
394      strcpy((*new_symbol)->id, in_string);      strcpy((*new_symbol)->id, in_string);
395    
396      /* Intern the new symbol in the hash table */      /* Intern the new symbol in the hash table */
# Line 294  void push_sym(environment *env, const ch Line 401  void push_sym(environment *env, const ch
401      if(handle==NULL)            /* If no handle */      if(handle==NULL)            /* If no handle */
402        handle= dlopen(NULL, RTLD_LAZY);        handle= dlopen(NULL, RTLD_LAZY);
403    
404      funcptr= dlsym(handle, in_string); /* Get function pointer */      mangled= mangle_str(in_string); /* mangle the name */
405      dlerr=dlerror();      funcptr= dlsym(handle, mangled); /* and try to find it */
406    
407        dlerr= dlerror();
408      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
409        mangled=mangle_str(in_string);        funcptr= dlsym(handle, in_string); /* Get function pointer */
410        funcptr= dlsym(handle, mangled); /* try mangling it */        dlerr= dlerror();
       free(mangled);  
       dlerr=dlerror();  
411      }      }
412    
413      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
414        new_fvalue= malloc(sizeof(value)); /* Create a new value */        new_fvalue->type= func;   /* The new value is a function pointer */
415        new_fvalue->type=func;    /* The new value is a function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
       new_fvalue->content.ptr=funcptr; /* Store function pointer */  
416        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
417                                           function value */                                           function value */
       new_fvalue->refcount= 1;  
418      }      }
419    
420        free(mangled);
421    }    }
   push(&(env->head), new_item);  
 }  
422    
423  /* Print newline. */    push_val(env, new_value);
424  extern void nl()    unprotect(new_value); unprotect(new_fvalue);
 {  
   printf("\n");  
425  }  }
426    
427  /* Gets the type of a value */  /* Print a value */
428  extern void type(environment *env){  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
429    int typenum;  {
430      stackitem *titem, *tstack;
431      int depth;
432    
433    if((env->head)==NULL) {    switch(val->type) {
434      printerr("Too Few Arguments");    case empty:
435      env->err=1;      if(fprintf(stream, "[]") < 0){
436      return;        perror("print_val");
437    }        env->err= 5;
438    typenum=env->head->item->type;        return;
439    toss(env);      }
   switch(typenum){  
   case integer:  
     push_sym(env, "integer");  
     break;  
   case string:  
     push_sym(env, "string");  
     break;  
   case symb:  
     push_sym(env, "symbol");  
     break;  
   case func:  
     push_sym(env, "function");  
     break;  
   case list:  
     push_sym(env, "list");  
440      break;      break;
   }  
 }      
   
 /* Prints the top element of the stack. */  
 void print_h(stackitem *stack_head)  
 {  
   switch(stack_head->item->type) {  
441    case integer:    case integer:
442      printf("%d", stack_head->item->content.val);      if(fprintf(stream, "%d", val->content.i) < 0){
443          perror("print_val");
444          env->err= 5;
445          return;
446        }
447        break;
448      case tfloat:
449        if(fprintf(stream, "%f", val->content.f) < 0){
450          perror("print_val");
451          env->err= 5;
452          return;
453        }
454      break;      break;
455    case string:    case string:
456      printf("%s", (char*)stack_head->item->content.ptr);      if(noquote){
457          if(fprintf(stream, "%s", (char*)(val->content.ptr)) < 0){
458            perror("print_val");
459            env->err= 5;
460            return;
461          }
462        } else {                    /* quote */
463          if(fprintf(stream, "\"%s\"", (char*)(val->content.ptr)) < 0){
464            perror("print_val");
465            env->err= 5;
466            return;
467          }
468        }
469      break;      break;
470    case symb:    case symb:
471      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      if(fprintf(stream, "%s", val->content.sym->id) < 0){
472          perror("print_val");
473          env->err= 5;
474          return;
475        }
476      break;      break;
477    case func:    case func:
478      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      if(fprintf(stream, "#<function %p>", (funcp)(val->content.ptr)) < 0){
479          perror("print_val");
480          env->err= 5;
481          return;
482        }
483      break;      break;
484    case list:    case port:
485      /* A list is just a stack, so make stack_head point to it */      if(fprintf(stream, "#<port %p>", (funcp)(val->content.p)) < 0){
486      stack_head=(stackitem *)(stack_head->item->content.ptr);        perror("print_val");
487      printf("[ ");        env->err= 5;
488      while(stack_head != NULL) {        return;
       print_h(stack_head);  
       printf(" ");  
       stack_head=stack_head->next;  
489      }      }
     printf("]");  
490      break;      break;
491    }    case tcons:
492  }      if(fprintf(stream, "[ ") < 0){
493          perror("print_val");
494  extern void print_(environment *env) {        env->err= 5;
495    if(env->head==NULL) {        return;
496      printerr("Too Few Arguments");      }
497      env->err=1;      tstack= stack;
498      return;      do {
499    }        titem=malloc(sizeof(stackitem));
500    print_h(env->head);        assert(titem != NULL);
501  }        titem->item=val;
502          titem->next=tstack;
503          tstack=titem;             /* Put it on the stack */
504          /* Search a stack of values being printed to see if we are already
505             printing this value */
506          titem=tstack;
507          depth=0;
508          while(titem != NULL && titem->item != CAR(val)){
509            titem=titem->next;
510            depth++;
511          }
512          if(titem != NULL){        /* If we found it on the stack, */
513            if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
514              perror("print_val");
515              env->err= 5;
516              free(titem);
517              return;
518            }
519          } else {
520            print_val(env, CAR(val), noquote, tstack, stream);
521          }
522          val= CDR(val);
523          switch(val->type){
524          case empty:
525            break;
526          case tcons:
527            /* Search a stack of values being printed to see if we are already
528               printing this value */
529            titem=tstack;
530            depth=0;
531            while(titem != NULL && titem->item != val){
532              titem=titem->next;
533              depth++;
534            }
535            if(titem != NULL){      /* If we found it on the stack, */
536              if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
537                perror("print_val");
538                env->err= 5;
539                goto printval_end;
540              }
541            } else {
542              if(fprintf(stream, " ") < 0){
543                perror("print_val");
544                env->err= 5;
545                goto printval_end;
546              }
547            }
548            break;
549          default:
550            if(fprintf(stream, " . ") < 0){ /* Improper list */
551              perror("print_val");
552              env->err= 5;
553              goto printval_end;
554            }
555            print_val(env, val, noquote, tstack, stream);
556          }
557        } while(val->type == tcons && titem == NULL);
558    
559  /* Prints the top element of the stack and then discards it. */    printval_end:
 extern void print(environment *env)  
 {  
   print_(env);  
   if(env->err) return;  
   toss(env);  
 }  
560    
561  /* Only to be called by function printstack. */      titem=tstack;
562  void print_st(stackitem *stack_head, long counter)      while(titem != stack){
563  {        tstack=titem->next;
564    if(stack_head->next != NULL)        free(titem);
565      print_st(stack_head->next, counter+1);        titem=tstack;
566    printf("%ld: ", counter);      }
   print_h(stack_head);  
   nl();  
 }  
567    
568  /* Prints the stack. */      if(! (env->err)){
569  extern void printstack(environment *env)        if(fprintf(stream, " ]") < 0){
570  {          perror("print_val");
571    if(env->head == NULL) {          env->err= 5;
572      return;        }
573        }
574        break;
575    }    }
   print_st(env->head, 1);  
   nl();  
576  }  }
577    
578  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
579  extern void swap(environment *env)  extern void swap(environment *env)
580  {  {
581    stackitem *temp= env->head;    value *temp= env->head;
582        
583    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
584      printerr("Too Few Arguments");      printerr("Too Few Arguments");
585      env->err=1;      env->err=1;
586      return;      return;
587    }    }
588    
589    env->head= env->head->next;    env->head= CDR(env->head);
590    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
591    env->head->next= temp;    CDR(env->head)= temp;
592  }  }
593    
 /* Rotate the first three elements on the stack. */  
 extern void rot(environment *env)  
 {  
   stackitem *temp= env->head;  
     
   if(env->head==NULL || env->head->next==NULL  
       || env->head->next->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
   
   env->head= env->head->next->next;  
   temp->next->next= env->head->next;  
   env->head->next= temp;  
 }  
   
594  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
595  extern void rcl(environment *env)  extern void rcl(environment *env)
596  {  {
597    value *val;    value *val;
598    
599    if(env->head == NULL) {    if(env->head->type==empty) {
600      printerr("Too Few Arguments");      printerr("Too Few Arguments");
601      env->err=1;      env->err= 1;
602      return;      return;
603    }    }
604    
605    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
606      printerr("Bad Argument Type");      printerr("Bad Argument Type");
607      env->err=2;      env->err= 2;
608      return;      return;
609    }    }
610    
611    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
612    if(val == NULL){    if(val == NULL){
613      printerr("Unbound Variable");      printerr("Unbound Variable");
614      env->err=3;      env->err= 3;
615      return;      return;
616    }    }
617    toss(env);            /* toss the symbol */    push_val(env, val);           /* Return the symbol's bound value */
618      swap(env);
619      if(env->err) return;
620      toss(env);                    /* toss the symbol */
621    if(env->err) return;    if(env->err) return;
   push_val(&(env->head), val); /* Return its bound value */  
622  }  }
623    
 void stack_read(environment*, char*);  
624    
625  /* If the top element is a symbol, determine if it's bound to a  /* If the top element is a symbol, determine if it's bound to a
626     function value, and if it is, toss the symbol and execute the     function value, and if it is, toss the symbol and execute the
# Line 487  extern void eval(environment *env) Line 629  extern void eval(environment *env)
629  {  {
630    funcp in_func;    funcp in_func;
631    value* temp_val;    value* temp_val;
632    stackitem* iterator;    value* iterator;
633    char* temp_string;  
634     eval_start:
635    
636    if(env->head==NULL) {    gc_maybe(env);
637    
638      if(env->head->type==empty) {
639      printerr("Too Few Arguments");      printerr("Too Few Arguments");
640      env->err=1;      env->err= 1;
641      return;      return;
642    }    }
643    
644   eval_start:    switch(CAR(env->head)->type) {
   
   switch(env->head->item->type) {  
645      /* if it's a symbol */      /* if it's a symbol */
646    case symb:    case symb:
647      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
648      if(env->err) return;      if(env->err) return;
649      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
650        goto eval_start;        goto eval_start;
651      }      }
652      return;      return;
653    
654      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
655    case func:    case func:
656      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
657      toss(env);      toss(env);
658      if(env->err) return;      if(env->err) return;
659      return (*in_func)(env);      return in_func(env);
660    
661      /* If it's a list */      /* If it's a list */
662    case list:    case tcons:
663      temp_val= env->head->item;      temp_val= CAR(env->head);
664      env->head->item->refcount++;      protect(temp_val);
665      toss(env);  
666      if(env->err) return;      toss(env); if(env->err) return;
667      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
668      while(iterator!=NULL) {      
669        push_val(&(env->head), iterator->item);      while(iterator->type != empty) {
670        if(env->head->item->type==symb        push_val(env, CAR(iterator));
671          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {        
672          if(CAR(env->head)->type==symb
673             && CAR(env->head)->content.sym->id[0]==';') {
674          toss(env);          toss(env);
675          if(env->err) return;          if(env->err) return;
676          if(iterator->next == NULL){          
677            free_val(temp_val);          if(CDR(iterator)->type == empty){
678            goto eval_start;            goto eval_start;
679          }          }
680          eval(env);          eval(env);
681          if(env->err) return;          if(env->err) return;
682        }        }
683        iterator= iterator->next;        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
684            iterator= CDR(iterator);
685          else {
686            printerr("Bad Argument Type"); /* Improper list */
687            env->err= 2;
688            return;
689          }
690      }      }
691      free_val(temp_val);      unprotect(temp_val);
692      return;      return;
693    
694      /* If it's a string */    case empty:
695    case string:      toss(env);
     temp_val= env->head->item;  
     env->head->item->refcount++;  
     toss(env);  
     if(env->err) return;  
     temp_string= malloc(strlen((char*)temp_val->content.ptr)+5);  
     strcpy(temp_string, "[ ");  
     strcpy(temp_string+2, (char*)temp_val->content.ptr);  
     free_val(temp_val);  
     strcat(temp_string, " ]");  
     stack_read(env, temp_string);  
     free(temp_string);  
     goto eval_start;  
   
696    case integer:    case integer:
697      case tfloat:
698      case string:
699      case port:
700      return;      return;
701    }    }
702  }  }
703    
704  /* Reverse (flip) a list */  /* List all defined words */
705  extern void rev(environment *env){  extern void words(environment *env)
706    stackitem *old_head, *new_head, *item;  {
707      symbol *temp;
708    if((env->head)==NULL) {    int i;
709      printerr("Too Few Arguments");    
710      env->err=1;    for(i= 0; i<HASHTBLSIZE; i++) {
711      return;      temp= env->symbols[i];
712    }      while(temp!=NULL) {
713    #ifdef DEBUG
714    if(env->head->item->type!=list) {        if (temp->val != NULL && temp->val->gc.flag.protect)
715      printerr("Bad Argument Type");          printf("(protected) ");
716      env->err=2;  #endif /* DEBUG */
717      return;        printf("%s ", temp->id);
718    }        temp= temp->next;
719        }
   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;  
720    }    }
   env->head->item->content.ptr=new_head;  
721  }  }
722    
723  /* Make a list. */  /* Quit stack. */
724  extern void pack(environment *env)  extern void quit(environment *env)
725  {  {
726    void* delimiter;    int i;
   stackitem *iterator, *temp;  
   value *pack;  
   
   delimiter= env->head->item->content.ptr; /* Get delimiter */  
   toss(env);  
   
   iterator= env->head;  
727    
728    if(iterator==NULL || iterator->item->content.ptr==delimiter) {    while(env->head->type != empty)
     temp= NULL;  
729      toss(env);      toss(env);
730    } else {  
731      /* Search for first delimiter */    if (env->err) return;
732      while(iterator->next!=NULL    for(i= 0; i<HASHTBLSIZE; i++) {
733            && iterator->next->item->content.ptr!=delimiter)      while(env->symbols[i]!= NULL) {
734        iterator= iterator->next;        forget_sym(&(env->symbols[i]));
735            }
736      /* Extract list */      env->symbols[i]= NULL;
     temp= env->head;  
     env->head= iterator->next;  
     iterator->next= NULL;  
       
     if(env->head!=NULL)  
       toss(env);  
737    }    }
738    
739    /* Push list */    env->gc_limit= 0;
740    pack= malloc(sizeof(value));    gc_maybe(env);
   pack->type= list;  
   pack->content.ptr= temp;  
   pack->refcount= 1;  
741    
742    temp= malloc(sizeof(stackitem));    words(env);
   temp->item= pack;  
743    
744    push(&(env->head), temp);    if(env->free_string!=NULL)
745    rev(env);      free(env->free_string);
746      
747    #ifdef __linux__
748      muntrace();
749    #endif
750    
751      exit(EXIT_SUCCESS);
752  }  }
753    
754  /* Parse input. */  /* Internal forget function */
755  void stack_read(environment *env, char *in_line)  void forget_sym(symbol **hash_entry)
756  {  {
757    char *temp, *rest;    symbol *temp;
   int itemp;  
   size_t inlength= strlen(in_line)+1;  
   int convert= 0;  
   
   temp= malloc(inlength);  
   rest= malloc(inlength);  
   
   do {  
     /* If comment */  
     if((convert= sscanf(in_line, "#%[^\n\r]", rest))) {  
       free(temp); free(rest);  
       return;  
     }  
   
     /* If string */  
     if((convert= sscanf(in_line, "\"%[^\"\n\r]\" %[^\n\r]", temp, rest))) {  
       push_cstring(&(env->head), temp);  
       break;  
     }  
     /* If integer */  
     if((convert= sscanf(in_line, "%d %[^\n\r]", &itemp, rest))) {  
       push_int(&(env->head), itemp);  
       break;  
     }  
     /* Escape ';' with '\' */  
     if((convert= sscanf(in_line, "\\%c%[^\n\r]", temp, rest))) {  
       temp[1]= '\0';  
       push_sym(env, temp);  
       break;  
     }  
     /* If symbol */  
     if((convert= sscanf(in_line, "%[^][ ;\n\r]%[^\n\r]", temp, rest))) {  
         push_sym(env, temp);  
         break;  
     }  
     /* If single char */  
     if((convert= sscanf(in_line, "%c%[^\n\r]", temp, rest))) {  
       if(*temp==';') {  
         if(!env->non_eval_flag) {  
           eval(env);            /* Evaluate top element */  
           break;  
         }  
           
         push_sym(env, ";");  
         break;  
       }  
   
       if(*temp==']') {  
         push_sym(env, "[");  
         pack(env);  
         if(env->non_eval_flag)  
           env->non_eval_flag--;  
         break;  
       }  
   
       if(*temp=='[') {  
         push_sym(env, "[");  
         env->non_eval_flag++;  
         break;  
       }  
     }  
   } while(0);  
758    
759      temp= *hash_entry;
760      *hash_entry= (*hash_entry)->next;
761      
762      free(temp->id);
763    free(temp);    free(temp);
764    }
765    
766    if(convert<2) {  /* Only to be called by itself function printstack. */
767      free(rest);  void print_st(environment *env, value *stack_head, long counter)
768      return;  {
769    }    if(CDR(stack_head)->type != empty)
770          print_st(env, CDR(stack_head), counter+1);
771    stack_read(env, rest);    printf("%ld: ", counter);
772        print_val(env, CAR(stack_head), 0, NULL, stdout);
773    free(rest);    printf("\n");
774  }  }
775    
776  /* Relocate elements of the list on the stack. */  /* Prints the stack. */
777  extern void expand(environment *env)  extern void printstack(environment *env)
778  {  {
779    stackitem *temp, *new_head;    if(env->head->type == empty) {
780        printf("Stack Empty\n");
   /* Is top element a list? */  
   if(env->head==NULL) {  
     printerr("Too Few Arguments");  
     env->err=1;  
781      return;      return;
782    }    }
   if(env->head->item->type!=list) {  
     printerr("Bad Argument Type");  
     env->err=2;  
     return;  
   }  
   
   rev(env);  
   
   if(env->err)  
     return;  
   
   /* The first list element is the new stack head */  
   new_head= temp= env->head->item->content.ptr;  
   
   env->head->item->refcount++;  
   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! */  
783    
784      print_st(env, env->head, 1);
785  }  }
786    
787  /* Compares two elements by reference. */  int main(int argc, char **argv)
 extern void eq(environment *env)  
788  {  {
789    void *left, *right;    environment myenv;
   int result;  
790    
791    if((env->head)==NULL || env->head->next==NULL) {    int c;                        /* getopt option character */
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
792    
793    left= env->head->item->content.ptr;  #ifdef __linux__
794    swap(env);    mtrace();
795    right= env->head->item->content.ptr;  #endif
   result= (left==right);  
     
   toss(env); toss(env);  
   push_int(&(env->head), result);  
 }  
796    
797  /* Negates the top element on the stack. */    init_env(&myenv);
 extern void not(environment *env)  
 {  
   int val;  
798    
799    if((env->head)==NULL) {    myenv.interactive = isatty(STDIN_FILENO) && isatty(STDOUT_FILENO);
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
800    
801    if(env->head->item->type!=integer) {    while ((c = getopt (argc, argv, "i")) != -1)
802      printerr("Bad Argument Type");      switch (c)
803      env->err=2;        {
804      return;        case 'i':
805            myenv.interactive = 1;
806            break;
807          case '?':
808            fprintf (stderr,
809                     "Unknown option character '\\x%x'.\n",
810                     optopt);
811            return EX_USAGE;
812          default:
813            abort ();
814          }
815      
816      if (optind < argc) {
817        myenv.interactive = 0;
818        myenv.inputstream= fopen(argv[optind], "r");
819        if(myenv.inputstream== NULL) {
820          perror(argv[0]);
821          exit (EX_NOINPUT);
822        }
823    }    }
824    
825    val= env->head->item->content.val;    if(myenv.interactive) {
826    toss(env);      printf("Stack version $Revision$\n\
827    push_int(&(env->head), !val);  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
828  }  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
829    This is free software, and you are welcome to redistribute it\n\
830    under certain conditions; type 'copying;' for details.\n");
831      }
832    
833  /* Compares the two top elements on the stack and return 0 if they're the    while(1) {
834     same. */      if(myenv.in_string==NULL) {
835  extern void neq(environment *env)        if (myenv.interactive) {
836  {          if(myenv.err) {
837    eq(env);            printf("(error %d)\n", myenv.err);
838    not(env);            myenv.err= 0;
839            }
840            printf("\n");
841            printstack(&myenv);
842            printf("> ");
843          }
844          myenv.err=0;
845        }
846        readstream(&myenv, myenv.inputstream);
847        if (myenv.err) {            /* EOF or other error */
848          myenv.err=0;
849          quit(&myenv);
850        } else if(myenv.head->type!=empty
851                  && CAR(myenv.head)->type==symb
852                  && CAR(myenv.head)->content.sym->id[0] == ';') {
853          toss(&myenv); if(myenv.err) continue;
854          eval(&myenv);
855        } else {
856          gc_maybe(&myenv);
857        }
858      }
859      quit(&myenv);
860      return EXIT_FAILURE;
861  }  }
862    
863  /* Give a symbol some content. */  /* Return copy of a value */
864  extern void def(environment *env)  value *copy_val(environment *env, value *old_value)
865  {  {
866    symbol *sym;    value *new_value;
   
   /* 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;  
   }  
867    
868    if(env->head->item->type!=symb) {    if(old_value==NULL)
869      printerr("Bad Argument Type");      return NULL;
     env->err=2;  
     return;  
   }  
870    
871    /* long names are a pain */    new_value= new_val(env);
872    sym=env->head->item->content.ptr;    new_value->type= old_value->type;
873    
874    /* if the symbol was bound to something else, throw it away */    switch(old_value->type){
875    if(sym->val != NULL)    case tfloat:
876      free_val(sym->val);    case integer:
877      case func:
878      case symb:
879      case empty:
880      case port:
881        new_value->content= old_value->content;
882        break;
883      case string:
884        (char *)(new_value->content.ptr)=
885          strdup((char *)(old_value->content.ptr));
886        break;
887      case tcons:
888    
889    /* Bind the symbol to the value */      new_value->content.c= malloc(sizeof(pair));
890    sym->val= env->head->next->item;      assert(new_value->content.c!=NULL);
891    sym->val->refcount++;         /* Increase the reference counter */      env->gc_count += sizeof(pair);
892    
893    toss(env); toss(env);      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
894  }      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
895        break;
896      }
897    
898  /* Quit stack. */    return new_value;
 extern void quit(environment *env)  
 {  
   exit(EXIT_SUCCESS);  
899  }  }
900    
901  /* Clear stack */  /* read a line from a stream; used by readline */
902  extern void clear(environment *env)  void readlinestream(environment *env, FILE *stream)
903  {  {
904    while(env->head!=NULL)    char in_string[101];
     toss(env);  
 }  
905    
906  /* List all defined words */    if(fgets(in_string, 100, stream)==NULL) {
907  extern void words(environment *env)      push_cstring(env, "");
908  {      if (! feof(stream)){
909    symbol *temp;        perror("readline");
910    int i;        env->err= 5;
     
   for(i= 0; i<HASHTBLSIZE; i++) {  
     temp= env->symbols[i];  
     while(temp!=NULL) {  
       printf("%s\n", temp->id);  
       temp= temp->next;  
911      }      }
912      } else {
913        push_cstring(env, in_string);
914    }    }
915  }  }
916    
917  /* Forgets a symbol (remove it from the hash table) */  /* Reverse (flip) a list */
918  extern void forget(environment *env)  extern void rev(environment *env)
919  {  {
920    char* sym_id;    value *old_head, *new_head, *item;
   stackitem *stack_head= env->head;  
   symbol **hash_entry, *temp;  
921    
922    if(stack_head==NULL) {    if(env->head->type==empty) {
923      printerr("Too Few Arguments");      printerr("Too Few Arguments");
924      env->err=1;      env->err= 1;
925      return;      return;
926    }    }
927      
928    if(stack_head->item->type!=symb) {    if(CAR(env->head)->type==empty)
929        return;                     /* Don't reverse an empty list */
930    
931      if(CAR(env->head)->type!=tcons) {
932      printerr("Bad Argument Type");      printerr("Bad Argument Type");
933      env->err=2;      env->err= 2;
934      return;      return;
935    }    }
936    
937    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    old_head= CAR(env->head);
938    toss(env);    new_head= new_val(env);
939      while(old_head->type != empty) {
940    hash_entry= hash(env->symbols, sym_id);      item= old_head;
941    temp= *hash_entry;      old_head= CDR(old_head);
942    *hash_entry= (*hash_entry)->next;      CDR(item)= new_head;
943          new_head= item;
   if(temp->val!=NULL) {  
     free_val(temp->val);  
944    }    }
945    free(temp->id);    CAR(env->head)= new_head;
   free(temp);  
 }  
   
 /* Returns the current error number to the stack */  
 extern void errn(environment *env){  
   push_int(&(env->head), env->err);  
946  }  }
947    
948  int main()  /* Make a list. */
949    extern void pack(environment *env)
950  {  {
951    environment myenv;    value *iterator, *temp, *ending;
   char in_string[100];  
952    
953    init_env(&myenv);    ending=new_val(env);
954    
955    printf("okidok\n ");    iterator= env->head;
956      if(iterator->type == empty
957         || (CAR(iterator)->type==symb
958         && CAR(iterator)->content.sym->id[0]=='[')) {
959        temp= ending;
960        toss(env);
961      } else {
962        /* Search for first delimiter */
963        while(CDR(iterator)->type != empty
964              && (CAR(CDR(iterator))->type!=symb
965               || CAR(CDR(iterator))->content.sym->id[0]!='['))
966          iterator= CDR(iterator);
967        
968        /* Extract list */
969        temp= env->head;
970        env->head= CDR(iterator);
971        CDR(iterator)= ending;
972    
973    while(fgets(in_string, 100, stdin) != NULL) {      if(env->head->type != empty)
974      stack_read(&myenv, in_string);        toss(env);
     if(myenv.err) {  
       printf("(error %d) ", myenv.err);  
       myenv.err=0;  
     }  
     printf("okidok\n ");  
975    }    }
   quit(&myenv);  
   return EXIT_FAILURE;  
 }  
   
 /* + */  
 extern void sx_2b(environment *env) {  
   int a, b;  
   size_t len;  
   char* new_string;  
   value *a_val, *b_val;  
976    
977    if((env->head)==NULL || env->head->next==NULL) {    /* Push list */
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
978    
979    if(env->head->item->type==string    push_val(env, temp);
980       && env->head->next->item->type==string) {    rev(env);
     a_val= env->head->item;  
     b_val= env->head->next->item;  
     a_val->refcount++;  
     b_val->refcount++;  
     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);  
     free_val(a_val); free_val(b_val);  
     push_cstring(&(env->head), new_string);  
     free(new_string);  
     return;  
   }  
     
   if(env->head->item->type!=integer  
      || env->head->next->item->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err=2;  
     return;  
   }  
   a=env->head->item->content.val;  
   toss(env);  
   if(env->err) return;  
   if(env->head->item->refcount == 1)  
     env->head->item->content.val += a;  
   else {  
     b=env->head->item->content.val;  
     toss(env);  
     if(env->err) return;  
     push_int(&(env->head), a+b);  
   }  
981  }  }
982    
983  /* - */  /* read from a stream; used by "read" and "readport" */
984  extern void sx_2d(environment *env) {  void readstream(environment *env, FILE *stream)
985    int a, b;  {
986      const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
987    if((env->head)==NULL || env->head->next==NULL) {    const char strform[]= "\"%[^\"]\"%n";
988      printerr("Too Few Arguments");    const char intform[]= "%i%n";
989      env->err=1;    const char fltform[]= "%f%n";
990      return;    const char blankform[]= "%*[ \t]%n";
991    }    const char ebrackform[]= "]%n";
992        const char semicform[]= ";%n";
993    if(env->head->item->type!=integer    const char bbrackform[]= "[%n";
994       || env->head->next->item->type!=integer) {  
995      printerr("Bad Argument Type");    int itemp, readlength= -1;
996      env->err=2;    int count= -1;
997      return;    float ftemp;
998    }    static int depth= 0;
999    a=env->head->item->content.val;    char *match;
1000    toss(env);    size_t inlength;
1001    if(env->err) return;  
1002    if(env->head->item->refcount == 1)    if(env->in_string==NULL) {
1003      env->head->item->content.val -= a;      if(depth > 0 && env->interactive) {
1004    else {        printf("]> ");
1005      b=env->head->item->content.val;      }
1006      toss(env);      readlinestream(env, env->inputstream);
1007      if(env->err) return;      if(env->err) return;
     push_int(&(env->head), b-a);  
   }  
 }  
1008    
1009  /* > */      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1010  extern void sx_3e(environment *env) {        env->err= 4;              /* "" means EOF */
1011    int a, b;        return;
1012        }
1013    if((env->head)==NULL || env->head->next==NULL) {      
1014      printerr("Too Few Arguments");      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1015      env->err=1;      assert(env->in_string != NULL);
1016      return;      env->free_string= env->in_string; /* Save the original pointer */
1017        strcpy(env->in_string, CAR(env->head)->content.ptr);
1018        toss(env); if(env->err) return;
1019    }    }
1020        
1021    if(env->head->item->type!=integer    inlength= strlen(env->in_string)+1;
1022       || env->head->next->item->type!=integer) {    match= malloc(inlength);
1023      printerr("Bad Argument Type");    assert(match != NULL);
1024      env->err=2;  
1025      return;    if(sscanf(env->in_string, blankform, &readlength) != EOF
1026         && readlength != -1) {
1027        ;
1028      } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
1029                && readlength != -1) {
1030        if(sscanf(env->in_string, intform, &itemp, &count) != EOF
1031           && count==readlength) {
1032          push_int(env, itemp);
1033        } else {
1034          push_float(env, ftemp);
1035        }
1036      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1037                && readlength != -1) {
1038        push_cstring(env, "");
1039      } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1040                && readlength != -1) {
1041        push_cstring(env, match);
1042      } else if(sscanf(env->in_string, symbform, match, &readlength) != EOF
1043                && readlength != -1) {
1044        push_sym(env, match);
1045      } else if(sscanf(env->in_string, ebrackform, &readlength) != EOF
1046                && readlength != -1) {
1047        pack(env); if(env->err) return;
1048        if(depth != 0) depth--;
1049      } else if(sscanf(env->in_string, semicform, &readlength) != EOF
1050                && readlength != -1) {
1051        push_sym(env, ";");
1052      } else if(sscanf(env->in_string, bbrackform, &readlength) != EOF
1053                && readlength != -1) {
1054        push_sym(env, "[");
1055        depth++;
1056      } else {
1057        free(env->free_string);
1058        env->in_string = env->free_string = NULL;
1059    }    }
1060    a=env->head->item->content.val;    if (env->in_string != NULL) {
1061    toss(env);      env->in_string += readlength;
   if(env->err) return;  
   if(env->head->item->refcount == 1)  
     env->head->item->content.val = (env->head->item->content.val > a);  
   else {  
     b=env->head->item->content.val;  
     toss(env);  
     if(env->err) return;  
     push_int(&(env->head), b>a);  
1062    }    }
 }  
1063    
1064  /* Return copy of a value */    free(match);
 value *copy_val(value *old_value){  
   stackitem *old_item, *new_item, *prev_item;  
   
   value *new_value=malloc(sizeof(value));  
1065    
1066    new_value->type=old_value->type;    if(depth)
1067    new_value->refcount=0;        /* This is increased if/when this      return readstream(env, env->inputstream);
1068                                     value is referenced somewhere, like  }
1069                                     in a stack item or a variable */  
1070    switch(old_value->type){  extern void copying(environment *env)
1071    case integer:  {
1072      new_value->content.val=old_value->content.val;    printf("                  GNU GENERAL PUBLIC LICENSE\n\
1073      break;                         Version 2, June 1991\n\
1074    case string:  \n\
1075      (char *)(new_value->content.ptr)   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
1076        = strdup((char *)(old_value->content.ptr));       59 Temple Place, Suite 330, Boston, MA  02111-1307  USA\n\
1077      break;   Everyone is permitted to copy and distribute verbatim copies\n\
1078    case func:   of this license document, but changing it is not allowed.\n\
1079    case symb:  \n\
1080      new_value->content.ptr=old_value->content.ptr;                              Preamble\n\
1081      break;  \n\
1082    case list:    The licenses for most software are designed to take away your\n\
1083      new_value->content.ptr=NULL;  freedom to share and change it.  By contrast, the GNU General Public\n\
1084    License is intended to guarantee your freedom to share and change free\n\
1085      prev_item=NULL;  software--to make sure the software is free for all its users.  This\n\
1086      old_item=(stackitem *)(old_value->content.ptr);  General Public License applies to most of the Free Software\n\
1087    Foundation's software and to any other program whose authors commit to\n\
1088      while(old_item != NULL) {   /* While list is not empty */  using it.  (Some other Free Software Foundation software is covered by\n\
1089        new_item= malloc(sizeof(stackitem));  the GNU Library General Public License instead.)  You can apply it to\n\
1090        new_item->item=copy_val(old_item->item); /* recurse */  your programs, too.\n\
1091        new_item->next=NULL;  \n\
1092        if(prev_item != NULL)     /* If this wasn't the first item */    When we speak of free software, we are referring to freedom, not\n\
1093          prev_item->next=new_item; /* point the previous item to the  price.  Our General Public Licenses are designed to make sure that you\n\
1094                                       new item */  have the freedom to distribute copies of free software (and charge for\n\
1095        else  this service if you wish), that you receive source code or can get it\n\
1096          new_value->content.ptr=new_item;  if you want it, that you can change the software or use pieces of it\n\
1097        old_item=old_item->next;  in new free programs; and that you know you can do these things.\n\
1098        prev_item=new_item;  \n\
1099      }        To protect your rights, we need to make restrictions that forbid\n\
1100      break;  anyone to deny you these rights or to ask you to surrender the rights.\n\
1101    }  These restrictions translate to certain responsibilities for you if you\n\
1102    return new_value;  distribute copies of the software, or if you modify it.\n\
1103  }  \n\
1104      For example, if you distribute copies of such a program, whether\n\
1105  /* duplicates an item on the stack */  gratis or for a fee, you must give the recipients all the rights that\n\
1106  extern void dup(environment *env) {  you have.  You must make sure that they, too, receive or can get the\n\
1107    if((env->head)==NULL) {  source code.  And you must show them these terms so they know their\n\
1108    rights.\n\
1109    \n\
1110      We protect your rights with two steps: (1) copyright the software, and\n\
1111    (2) offer you this license which gives you legal permission to copy,\n\
1112    distribute and/or modify the software.\n\
1113    \n\
1114      Also, for each author's protection and ours, we want to make certain\n\
1115    that everyone understands that there is no warranty for this free\n\
1116    software.  If the software is modified by someone else and passed on, we\n\
1117    want its recipients to know that what they have is not the original, so\n\
1118    that any problems introduced by others will not reflect on the original\n\
1119    authors' reputations.\n\
1120    \n\
1121      Finally, any free program is threatened constantly by software\n\
1122    patents.  We wish to avoid the danger that redistributors of a free\n\
1123    program will individually obtain patent licenses, in effect making the\n\
1124    program proprietary.  To prevent this, we have made it clear that any\n\
1125    patent must be licensed for everyone's free use or not licensed at all.\n\
1126    \n\
1127      The precise terms and conditions for copying, distribution and\n\
1128    modification follow.\n\
1129    \n\
1130                        GNU GENERAL PUBLIC LICENSE\n\
1131       TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION\n\
1132    \n\
1133      0. This License applies to any program or other work which contains\n\
1134    a notice placed by the copyright holder saying it may be distributed\n\
1135    under the terms of this General Public License.  The \"Program\", below,\n\
1136    refers to any such program or work, and a \"work based on the Program\"\n\
1137    means either the Program or any derivative work under copyright law:\n\
1138    that is to say, a work containing the Program or a portion of it,\n\
1139    either verbatim or with modifications and/or translated into another\n\
1140    language.  (Hereinafter, translation is included without limitation in\n\
1141    the term \"modification\".)  Each licensee is addressed as \"you\".\n\
1142    \n\
1143    Activities other than copying, distribution and modification are not\n\
1144    covered by this License; they are outside its scope.  The act of\n\
1145    running the Program is not restricted, and the output from the Program\n\
1146    is covered only if its contents constitute a work based on the\n\
1147    Program (independent of having been made by running the Program).\n\
1148    Whether that is true depends on what the Program does.\n\
1149    \n\
1150      1. You may copy and distribute verbatim copies of the Program's\n\
1151    source code as you receive it, in any medium, provided that you\n\
1152    conspicuously and appropriately publish on each copy an appropriate\n\
1153    copyright notice and disclaimer of warranty; keep intact all the\n\
1154    notices that refer to this License and to the absence of any warranty;\n\
1155    and give any other recipients of the Program a copy of this License\n\
1156    along with the Program.\n\
1157    \n\
1158    You may charge a fee for the physical act of transferring a copy, and\n\
1159    you may at your option offer warranty protection in exchange for a fee.\n\
1160    \n\
1161      2. You may modify your copy or copies of the Program or any portion\n\
1162    of it, thus forming a work based on the Program, and copy and\n\
1163    distribute such modifications or work under the terms of Section 1\n\
1164    above, provided that you also meet all of these conditions:\n\
1165    \n\
1166        a) You must cause the modified files to carry prominent notices\n\
1167        stating that you changed the files and the date of any change.\n\
1168    \n\
1169        b) You must cause any work that you distribute or publish, that in\n\
1170        whole or in part contains or is derived from the Program or any\n\
1171        part thereof, to be licensed as a whole at no charge to all third\n\
1172        parties under the terms of this License.\n\
1173    \n\
1174        c) If the modified program normally reads commands interactively\n\
1175        when run, you must cause it, when started running for such\n\
1176        interactive use in the most ordinary way, to print or display an\n\
1177        announcement including an appropriate copyright notice and a\n\
1178        notice that there is no warranty (or else, saying that you provide\n\
1179        a warranty) and that users may redistribute the program under\n\
1180        these conditions, and telling the user how to view a copy of this\n\
1181        License.  (Exception: if the Program itself is interactive but\n\
1182        does not normally print such an announcement, your work based on\n\
1183        the Program is not required to print an announcement.)\n\
1184    \n\
1185    These requirements apply to the modified work as a whole.  If\n\
1186    identifiable sections of that work are not derived from the Program,\n\
1187    and can be reasonably considered independent and separate works in\n\
1188    themselves, then this License, and its terms, do not apply to those\n\
1189    sections when you distribute them as separate works.  But when you\n\
1190    distribute the same sections as part of a whole which is a work based\n\
1191    on the Program, the distribution of the whole must be on the terms of\n\
1192    this License, whose permissions for other licensees extend to the\n\
1193    entire whole, and thus to each and every part regardless of who wrote it.\n\
1194    \n\
1195    Thus, it is not the intent of this section to claim rights or contest\n\
1196    your rights to work written entirely by you; rather, the intent is to\n\
1197    exercise the right to control the distribution of derivative or\n\
1198    collective works based on the Program.\n\
1199    \n\
1200    In addition, mere aggregation of another work not based on the Program\n\
1201    with the Program (or with a work based on the Program) on a volume of\n\
1202    a storage or distribution medium does not bring the other work under\n\
1203    the scope of this License.\n\
1204    \n\
1205      3. You may copy and distribute the Program (or a work based on it,\n\
1206    under Section 2) in object code or executable form under the terms of\n\
1207    Sections 1 and 2 above provided that you also do one of the following:\n\
1208    \n\
1209        a) Accompany it with the complete corresponding machine-readable\n\
1210        source code, which must be distributed under the terms of Sections\n\
1211        1 and 2 above on a medium customarily used for software interchange; or,\n\
1212    \n\
1213        b) Accompany it with a written offer, valid for at least three\n\
1214        years, to give any third party, for a charge no more than your\n\
1215        cost of physically performing source distribution, a complete\n\
1216        machine-readable copy of the corresponding source code, to be\n\
1217        distributed under the terms of Sections 1 and 2 above on a medium\n\
1218        customarily used for software interchange; or,\n\
1219    \n\
1220        c) Accompany it with the information you received as to the offer\n\
1221        to distribute corresponding source code.  (This alternative is\n\
1222        allowed only for noncommercial distribution and only if you\n\
1223        received the program in object code or executable form with such\n\
1224        an offer, in accord with Subsection b above.)\n\
1225    \n\
1226    The source code for a work means the preferred form of the work for\n\
1227    making modifications to it.  For an executable work, complete source\n\
1228    code means all the source code for all modules it contains, plus any\n\
1229    associated interface definition files, plus the scripts used to\n\
1230    control compilation and installation of the executable.  However, as a\n\
1231    special exception, the source code distributed need not include\n\
1232    anything that is normally distributed (in either source or binary\n\
1233    form) with the major components (compiler, kernel, and so on) of the\n\
1234    operating system on which the executable runs, unless that component\n\
1235    itself accompanies the executable.\n\
1236    \n\
1237    If distribution of executable or object code is made by offering\n\
1238    access to copy from a designated place, then offering equivalent\n\
1239    access to copy the source code from the same place counts as\n\
1240    distribution of the source code, even though third parties are not\n\
1241    compelled to copy the source along with the object code.\n\
1242    \n\
1243      4. You may not copy, modify, sublicense, or distribute the Program\n\
1244    except as expressly provided under this License.  Any attempt\n\
1245    otherwise to copy, modify, sublicense or distribute the Program is\n\
1246    void, and will automatically terminate your rights under this License.\n\
1247    However, parties who have received copies, or rights, from you under\n\
1248    this License will not have their licenses terminated so long as such\n\
1249    parties remain in full compliance.\n\
1250    \n\
1251      5. You are not required to accept this License, since you have not\n\
1252    signed it.  However, nothing else grants you permission to modify or\n\
1253    distribute the Program or its derivative works.  These actions are\n\
1254    prohibited by law if you do not accept this License.  Therefore, by\n\
1255    modifying or distributing the Program (or any work based on the\n\
1256    Program), you indicate your acceptance of this License to do so, and\n\
1257    all its terms and conditions for copying, distributing or modifying\n\
1258    the Program or works based on it.\n\
1259    \n\
1260      6. Each time you redistribute the Program (or any work based on the\n\
1261    Program), the recipient automatically receives a license from the\n\
1262    original licensor to copy, distribute or modify the Program subject to\n\
1263    these terms and conditions.  You may not impose any further\n\
1264    restrictions on the recipients' exercise of the rights granted herein.\n\
1265    You are not responsible for enforcing compliance by third parties to\n\
1266    this License.\n\
1267    \n\
1268      7. If, as a consequence of a court judgment or allegation of patent\n\
1269    infringement or for any other reason (not limited to patent issues),\n\
1270    conditions are imposed on you (whether by court order, agreement or\n\
1271    otherwise) that contradict the conditions of this License, they do not\n\
1272    excuse you from the conditions of this License.  If you cannot\n\
1273    distribute so as to satisfy simultaneously your obligations under this\n\
1274    License and any other pertinent obligations, then as a consequence you\n\
1275    may not distribute the Program at all.  For example, if a patent\n\
1276    license would not permit royalty-free redistribution of the Program by\n\
1277    all those who receive copies directly or indirectly through you, then\n\
1278    the only way you could satisfy both it and this License would be to\n\
1279    refrain entirely from distribution of the Program.\n\
1280    \n\
1281    If any portion of this section is held invalid or unenforceable under\n\
1282    any particular circumstance, the balance of the section is intended to\n\
1283    apply and the section as a whole is intended to apply in other\n\
1284    circumstances.\n\
1285    \n\
1286    It is not the purpose of this section to induce you to infringe any\n\
1287    patents or other property right claims or to contest validity of any\n\
1288    such claims; this section has the sole purpose of protecting the\n\
1289    integrity of the free software distribution system, which is\n\
1290    implemented by public license practices.  Many people have made\n\
1291    generous contributions to the wide range of software distributed\n\
1292    through that system in reliance on consistent application of that\n\
1293    system; it is up to the author/donor to decide if he or she is willing\n\
1294    to distribute software through any other system and a licensee cannot\n\
1295    impose that choice.\n\
1296    \n\
1297    This section is intended to make thoroughly clear what is believed to\n\
1298    be a consequence of the rest of this License.\n\
1299    \n\
1300      8. If the distribution and/or use of the Program is restricted in\n\
1301    certain countries either by patents or by copyrighted interfaces, the\n\
1302    original copyright holder who places the Program under this License\n\
1303    may add an explicit geographical distribution limitation excluding\n\
1304    those countries, so that distribution is permitted only in or among\n\
1305    countries not thus excluded.  In such case, this License incorporates\n\
1306    the limitation as if written in the body of this License.\n\
1307    \n\
1308      9. The Free Software Foundation may publish revised and/or new versions\n\
1309    of the General Public License from time to time.  Such new versions will\n\
1310    be similar in spirit to the present version, but may differ in detail to\n\
1311    address new problems or concerns.\n\
1312    \n\
1313    Each version is given a distinguishing version number.  If the Program\n\
1314    specifies a version number of this License which applies to it and \"any\n\
1315    later version\", you have the option of following the terms and conditions\n\
1316    either of that version or of any later version published by the Free\n\
1317    Software Foundation.  If the Program does not specify a version number of\n\
1318    this License, you may choose any version ever published by the Free Software\n\
1319    Foundation.\n\
1320    \n\
1321      10. If you wish to incorporate parts of the Program into other free\n\
1322    programs whose distribution conditions are different, write to the author\n\
1323    to ask for permission.  For software which is copyrighted by the Free\n\
1324    Software Foundation, write to the Free Software Foundation; we sometimes\n\
1325    make exceptions for this.  Our decision will be guided by the two goals\n\
1326    of preserving the free status of all derivatives of our free software and\n\
1327    of promoting the sharing and reuse of software generally.\n");
1328    }
1329    
1330    extern void warranty(environment *env)
1331    {
1332      printf("                          NO WARRANTY\n\
1333    \n\
1334      11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\
1335    FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN\n\
1336    OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES\n\
1337    PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED\n\
1338    OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF\n\
1339    MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS\n\
1340    TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE\n\
1341    PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,\n\
1342    REPAIR OR CORRECTION.\n\
1343    \n\
1344      12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING\n\
1345    WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR\n\
1346    REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,\n\
1347    INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING\n\
1348    OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED\n\
1349    TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY\n\
1350    YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER\n\
1351    PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE\n\
1352    POSSIBILITY OF SUCH DAMAGES.\n");
1353    }
1354    
1355    /* General assoc function */
1356    void assocgen(environment *env, funcp eqfunc)
1357    {
1358      value *key, *item;
1359    
1360      /* Needs two values on the stack, the top one must be an association
1361         list */
1362      if(env->head->type==empty || CDR(env->head)->type==empty) {
1363      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1364      env->err=1;      env->err= 1;
1365      return;      return;
1366    }    }
   push_val(&(env->head), copy_val(env->head->item));  
 }  
   
 /* "if", If-Then */  
 extern void sx_6966(environment *env) {  
   
   int truth;  
1367    
1368    if((env->head)==NULL || env->head->next==NULL) {    if(CAR(env->head)->type!=tcons) {
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
   
   if(env->head->next->item->type != integer) {  
1369      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1370      env->err=2;      env->err= 2;
1371      return;      return;
1372    }    }
     
   swap(env);  
   if(env->err) return;  
     
   truth=env->head->item->content.val;  
1373    
1374    toss(env);    key=CAR(CDR(env->head));
1375    if(env->err) return;    item=CAR(env->head);
1376    
1377    if(truth)    while(item->type == tcons){
1378      eval(env);      if(CAR(item)->type != tcons){
1379    else        printerr("Bad Argument Type");
1380      toss(env);        env->err= 2;
1381  }        return;
1382        }
1383        push_val(env, key);
1384        push_val(env, CAR(CAR(item)));
1385        eqfunc(env); if(env->err) return;
1386    
1387        /* Check the result of 'eqfunc' */
1388        if(env->head->type==empty) {
1389          printerr("Too Few Arguments");
1390          env->err= 1;
1391        return;
1392        }
1393        if(CAR(env->head)->type!=integer) {
1394          printerr("Bad Argument Type");
1395          env->err= 2;
1396          return;
1397        }
1398    
1399  /* If-Then-Else */      if(CAR(env->head)->content.i){
1400  extern void ifelse(environment *env) {        toss(env); if(env->err) return;
1401          break;
1402        }
1403        toss(env); if(env->err) return;
1404    
1405    int truth;      if(item->type!=tcons) {
1406          printerr("Bad Argument Type");
1407          env->err= 2;
1408          return;
1409        }
1410    
1411    if((env->head)==NULL || env->head->next==NULL      item=CDR(item);
      || env->head->next->next==NULL) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
1412    }    }
1413    
1414    if(env->head->next->next->item->type != integer) {    if(item->type == tcons){      /* A match was found */
1415      printerr("Bad Argument Type");      push_val(env, CAR(item));
1416      env->err=2;    } else {
1417      return;      push_int(env, 0);
1418    }    }
1419        swap(env); if(env->err) return;
1420    rot(env);    toss(env); if(env->err) return;
1421    if(env->err) return;    swap(env); if(env->err) return;
     
   truth=env->head->item->content.val;  
   
   toss(env);  
   if(env->err) return;  
   
   if(!truth)  
     swap(env);  
   if(env->err) return;  
   
1422    toss(env);    toss(env);
   if(env->err) return;  
   
   eval(env);  
1423  }  }
1424    
1425  /* while */  /* Discard the top element of the stack. */
1426  extern void sx_7768696c65(environment *env) {  extern void toss(environment *env)
1427    {
1428    int truth;    if(env->head->type==empty) {
   value *loop, *test;  
   
   if((env->head)==NULL || env->head->next==NULL) {  
1429      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1430      env->err=1;      env->err= 1;
1431      return;      return;
1432    }    }
   
   loop= env->head->item;  
   loop->refcount++;  
   toss(env); if(env->err) return;  
   
   test= env->head->item;  
   test->refcount++;  
   toss(env); if(env->err) return;  
   
   do {  
     push_val(&(env->head), test);  
     eval(env);  
       
     if(env->head->item->type != integer) {  
       printerr("Bad Argument Type");  
       env->err=2;  
       return;  
     }  
       
     truth= env->head->item->content.val;  
     toss(env); if(env->err) return;  
       
     if(truth) {  
       push_val(&(env->head), loop);  
       eval(env);  
     } else {  
       toss(env);  
     }  
1433        
1434    } while(truth);    env->head= CDR(env->head); /* Remove the top stack item */
   
   free_val(test);  
   free_val(loop);  
1435  }  }
1436    
Legend:
Removed from v.1.64  
changed lines
  Added in v.1.126
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26