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

Diff of /stack/stack.c

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

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