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

Diff of /stack/stack.c

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

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