/[cvs]/stack/stack.c

Diff of /stack/stack.c

Parent Directory | Revision Log | View Patch Patch

-revision 1.33 by teddy,
Tue Feb  5 23:00:42 2002 UTC
+revision 1.122 by masse,
Wed Mar 27 14:49:56 2002 UTC
 Line 1
- /* printf */
+ /* -*- coding: utf-8; -*- */
+ /*
+     stack - an interactive interpreter for a stack-based language
+     Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn
+     This program is free software; you can redistribute it and/or modify
+     it under the terms of the GNU General Public License as published by
+     the Free Software Foundation; either version 2 of the License, or
+     (at your option) any later version.
+     This program is distributed in the hope that it will be useful,
+     but WITHOUT ANY WARRANTY; without even the implied warranty of
+     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+     GNU General Public License for more details.
+     You should have received a copy of the GNU General Public License
+     along with this program; if not, write to the Free Software
+     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+     Authors: Mats Alritzson <masse@fukt.bth.se>
+              Teddy Hogeborn <teddy@fukt.bth.se>
+ */
+ #define CAR(X) ((X)->content.c->car)
+ #define CDR(X) ((X)->content.c->cdr)
+ /* printf, sscanf, fgets, fprintf, fopen, perror */
  #include <stdio.h>
- /* EXIT_SUCCESS */
+ /* exit, EXIT_SUCCESS, malloc, free */
  #include <stdlib.h>
  /* NULL */
  #include <stddef.h>
  /* dlopen, dlsym, dlerror */
  #include <dlfcn.h>
+ /* strcmp, strcpy, strlen, strcat, strdup */
+ #include <string.h>
+ /* getopt, STDIN_FILENO, STDOUT_FILENO, usleep */
+ #include <unistd.h>
+ /* EX_NOINPUT, EX_USAGE */
+ #include <sysexits.h>
  /* assert */
  #include <assert.h>
- #define HASHTBLSIZE 65536
+ #ifdef __linux__
+ /* mtrace, muntrace */
- /* First, define some types. */
+ #include <mcheck.h>
+ /* ioctl */
+ #include <sys/ioctl.h>
+ /* KDMKTONE */
+ #include <linux/kd.h>
+ #endif /* __linux__ */
- /* A value of some type */
+ #include "stack.h"
- typedef struct {
-   enum {
-     integer,
-     string,
-     ref,                        /* Reference (to an element in the
-                                    hash table) */
-     func,                       /* Function pointer */
-     symb,
-     list
-   } type;                       /* Type of stack element */
-   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 */
-   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 */
- } environment;
- /* A type for pointers to external functions */
- typedef void (*funcp)(environment *); /* funcp is a pointer to a void
-                                          function (environment *) */
  /* Initialize a newly created environment */
  void init_env(environment *env)
  {
-   long i;
+   int i;
+   env->gc_limit= 400000;
+   env->gc_count= 0;
+   env->gc_ref= NULL;
+   env->head= new_val(env);
    for(i= 0; i<HASHTBLSIZE; i++)
      env->symbols[i]= NULL;
+   env->err= 0;
+   env->in_string= NULL;
+   env->free_string= NULL;
+   env->inputstream= stdin;
+   env->interactive= 1;
+ }
+ void printerr(const char* in_string)
+ {
+   fprintf(stderr, "Err: %s\n", in_string);
+ }
+ /* Discard the top element of the stack. */
+ extern void toss(environment *env)
+ {
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   env->head= CDR(env->head); /* Remove the top stack item */
  }
  /* Returns a pointer to a pointer to an element in the hash table. */
  symbol **hash(hashtbl in_hashtbl, const char *in_string)
  {
-   long i= 0;
+   int i= 0;
-   unsigned long out_hash= 0;
+   unsigned int out_hash= 0;
    char key= '\0';
    symbol **position;
-Line 103 
 symbol **hash(hashtbl in_hashtbl, const
+Line 117 
 symbol **hash(hashtbl in_hashtbl, const
    }
  }
- /* Generic push function. */
+ /* Create new value */
- int push(stackitem** stack_head, stackitem* in_item)
+ value* new_val(environment *env)
+ {
+   value *nval= malloc(sizeof(value));
+   stackitem *nitem= malloc(sizeof(stackitem));
+   assert(nval != NULL);
+   assert(nitem != NULL);
+   nval->content.ptr= NULL;
+   nval->type= empty;
+   nitem->item= nval;
+   nitem->next= env->gc_ref;
+   env->gc_ref= nitem;
+   env->gc_count += sizeof(value);
+   nval->gc.flag.mark= 0;
+   nval->gc.flag.protect= 0;
+   return nval;
+ }
+ /* Mark values recursively.
+    Marked values are not collected by the GC. */
+ inline void gc_mark(value *val)
+ {
+   if(val==NULL || val->gc.flag.mark)
+     return;
+   val->gc.flag.mark= 1;
+   if(val->type==tcons) {
+     gc_mark(CAR(val));
+     gc_mark(CDR(val));
+   }
+ }
+ inline void gc_maybe(environment *env)
+ {
+   if(env->gc_count < env->gc_limit)
+     return;
+   else
+     return gc_init(env);
+ }
+ /* Start GC */
+ extern void gc_init(environment *env)
+ {
+   stackitem *new_head= NULL, *titem;
+   symbol *tsymb;
+   int i;
+   if(env->interactive)
+     printf("Garbage collecting.");
+   /* Mark values on stack */
+   gc_mark(env->head);
+   if(env->interactive)
+     printf(".");
+   /* Mark values in hashtable */
+   for(i= 0; i<HASHTBLSIZE; i++)
+     for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
+       if (tsymb->val != NULL)
+         gc_mark(tsymb->val);
+   if(env->interactive)
+     printf(".");
+   env->gc_count= 0;
+   while(env->gc_ref!=NULL) {    /* Sweep unused values */
+     if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
+       /* Remove content */
+       switch(env->gc_ref->item->type){
+       case string:
+         free(env->gc_ref->item->content.ptr);
+         break;
+       case tcons:
+         free(env->gc_ref->item->content.c);
+         break;
+       case empty:
+       case integer:
+       case tfloat:
+       case func:
+       case symb:
+         /* Symbol strings are freed when walking the hash table */
+       }
+       free(env->gc_ref->item);  /* Remove from gc_ref */
+       titem= env->gc_ref->next;
+       free(env->gc_ref);        /* Remove value */
+       env->gc_ref= titem;
+       continue;
+     }
+ #ifdef DEBUG
+     printf("Kept value (%p)", env->gc_ref->item);
+     if(env->gc_ref->item->gc.flag.mark)
+       printf(" (marked)");
+     if(env->gc_ref->item->gc.flag.protect)
+       printf(" (protected)");
+     switch(env->gc_ref->item->type){
+     case integer:
+       printf(" integer: %d", env->gc_ref->item->content.i);
+       break;
+     case func:
+       printf(" func: %p", env->gc_ref->item->content.ptr);
+       break;
+     case symb:
+       printf(" symb: %s", env->gc_ref->item->content.sym->id);
+       break;
+     case tcons:
+       printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
+              env->gc_ref->item->content.c->cdr);
+       break;
+     default:
+       printf(" <unknown %d>", (env->gc_ref->item->type));
+     }
+     printf("\n");
+ #endif /* DEBUG */
+     /* Keep values */
+     env->gc_count += sizeof(value);
+     if(env->gc_ref->item->type==string)
+       env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
+     titem= env->gc_ref->next;
+     env->gc_ref->next= new_head;
+     new_head= env->gc_ref;
+     new_head->item->gc.flag.mark= 0;
+     env->gc_ref= titem;
+   }
+   if (env->gc_limit < env->gc_count*2)
+     env->gc_limit= env->gc_count*2;
+   env->gc_ref= new_head;
+   if(env->interactive)
+     printf("done (%d bytes still allocated)\n", env->gc_count);
+ }
+ /* Protect values from GC */
+ void protect(value *val)
  {
-   in_item->next= *stack_head;
+   if(val==NULL || val->gc.flag.protect)
-   *stack_head= in_item;
+     return;
-   return 1;
+   val->gc.flag.protect= 1;
+   if(val->type==tcons) {
+     protect(CAR(val));
+     protect(CDR(val));
+   }
+ }
+ /* Unprotect values from GC */
+ void unprotect(value *val)
+ {
+   if(val==NULL || !(val->gc.flag.protect))
+     return;
+   val->gc.flag.protect= 0;
+   if(val->type==tcons) {
+     unprotect(CAR(val));
+     unprotect(CDR(val));
+   }
  }
  /* Push a value onto the stack */
- void push_val(stackitem **stack_head, value *val)
+ void push_val(environment *env, value *val)
  {
-   stackitem *new_item= malloc(sizeof(stackitem));
+   value *new_value= new_val(env);
-   new_item->item= val;
-   val->refcount++;
+   new_value->content.c= malloc(sizeof(pair));
-   push(stack_head, new_item);
+   assert(new_value->content.c!=NULL);
+   env->gc_count += sizeof(pair);
+   new_value->type= tcons;
+   CAR(new_value)= val;
+   CDR(new_value)= env->head;
+   env->head= new_value;
  }
- /* Push an integer onto the stack. */
+ /* Push an integer onto the stack */
- int push_int(stackitem **stack_head, int in_val)
+ void push_int(environment *env, int in_val)
  {
-   value *new_value= malloc(sizeof(value));
+   value *new_value= new_val(env);
-   stackitem *new_item= malloc(sizeof(stackitem));
-   new_item->item= new_value;
-   new_value->content.val= in_val;
+   new_value->content.i= in_val;
    new_value->type= integer;
-   new_value->refcount=1;
-   push(stack_head, new_item);
+   push_val(env, new_value);
-   return 1;
+ }
+ /* Push a floating point number onto the stack */
+ void push_float(environment *env, float in_val)
+ {
+   value *new_value= new_val(env);
+   new_value->content.f= in_val;
+   new_value->type= tfloat;
+   push_val(env, new_value);
  }
  /* Copy a string onto the stack. */
- int push_cstring(stackitem **stack_head, const char *in_string)
+ void push_cstring(environment *env, const char *in_string)
  {
-   value *new_value= malloc(sizeof(value));
+   value *new_value= new_val(env);
-   stackitem *new_item= malloc(sizeof(stackitem));
+   int length= strlen(in_string)+1;
-   new_item->item=new_value;
-   new_value->content.ptr= malloc(strlen(in_string)+1);
+   new_value->content.ptr= malloc(length);
+   assert(new_value != NULL);
+   env->gc_count += length;
    strcpy(new_value->content.ptr, in_string);
    new_value->type= string;
-   new_value->refcount=1;
-   push(stack_head, new_item);
+   push_val(env, new_value);
-   return 1;
+ }
+ /* Mangle a symbol name to a valid C identifier name */
+ char *mangle_str(const char *old_string)
+ {
+   char validchars[]= "0123456789abcdef";
+   char *new_string, *current;
+   new_string= malloc((strlen(old_string)*2)+4);
+   assert(new_string != NULL);
+   strcpy(new_string, "sx_");    /* Stack eXternal */
+   current= new_string+3;
+   while(old_string[0] != '\0'){
+     current[0]= validchars[(unsigned char)(old_string[0])/16];
+     current[1]= validchars[(unsigned char)(old_string[0])%16];
+     current+= 2;
+     old_string++;
+   }
+   current[0]= '\0';
+   return new_string;            /* The caller must free() it */
+ }
+ extern void mangle(environment *env)
+ {
+   char *new_string;
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type!=string) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   new_string=
+     mangle_str((const char *)(CAR(env->head)->content.ptr));
+   toss(env);
+   if(env->err) return;
+   push_cstring(env, new_string);
  }
  /* Push a symbol onto the stack. */
- int push_sym(environment *env, const char *in_string)
+ void push_sym(environment *env, const char *in_string)
  {
-   stackitem *new_item;          /* The new stack item */
-   /* ...which will contain... */
    value *new_value;             /* A new symbol value */
    /* ...which might point to... */
    symbol **new_symbol;          /* (if needed) A new actual symbol */
-Line 165 
 int push_sym(environment *env, const cha
+Line 404 
 int push_sym(environment *env, const cha
    void *funcptr;                /* A function pointer */
    static void *handle= NULL;    /* Dynamic linker handle */
+   const char *dlerr;            /* Dynamic linker error */
+   char *mangled;                /* Mangled function name */
-   /* Create a new stack item containing a new value */
+   new_value= new_val(env);
-   new_item= malloc(sizeof(stackitem));
+   protect(new_value);
-   new_value= malloc(sizeof(value));
+   new_fvalue= new_val(env);
-   new_item->item=new_value;
+   protect(new_fvalue);
    /* The new value is a symbol */
    new_value->type= symb;
-   new_value->refcount= 1;
    /* Look up the symbol name in the hash table */
    new_symbol= hash(env->symbols, in_string);
-Line 183 
 int push_sym(environment *env, const cha
+Line 423 
 int push_sym(environment *env, const cha
      /* Create a new symbol */
      (*new_symbol)= malloc(sizeof(symbol));
+     assert((*new_symbol) != NULL);
      (*new_symbol)->val= NULL;   /* undefined value */
      (*new_symbol)->next= NULL;
      (*new_symbol)->id= malloc(strlen(in_string)+1);
+     assert((*new_symbol)->id != NULL);
      strcpy((*new_symbol)->id, in_string);
      /* Intern the new symbol in the hash table */
-Line 196 
 int push_sym(environment *env, const cha
+Line 438 
 int push_sym(environment *env, const cha
      if(handle==NULL)            /* If no handle */
        handle= dlopen(NULL, RTLD_LAZY);
-     funcptr= dlsym(handle, in_string); /* Get function pointer */
+     mangled= mangle_str(in_string); /* mangle the name */
-     if(dlerror()==NULL) {       /* If a function was found */
+     funcptr= dlsym(handle, mangled); /* and try to find it */
-       new_fvalue= malloc(sizeof(value)); /* Create a new value */
-       new_fvalue->type=func;    /* The new value is a function pointer */
+     dlerr= dlerror();
-       new_fvalue->content.ptr=funcptr; /* Store function pointer */
+     if(dlerr != NULL) {         /* If no function was found */
+       funcptr= dlsym(handle, in_string); /* Get function pointer */
+       dlerr= dlerror();
+     }
+     if(dlerr==NULL) {           /* If a function was found */
+       new_fvalue->type= func;   /* The new value is a function pointer */
+       new_fvalue->content.ptr= funcptr; /* Store function pointer */
        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
                                           function value */
-       new_fvalue->refcount= 1;
      }
-   }
-   push(&(env->head), new_item);
-   return 1;
- }
- void printerr(const char* in_string) {
+     free(mangled);
-   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);
-     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;
-     default:
-       break;
-     }
    }
- }
- /* Discard the top element of the stack. */
- extern void toss(environment *env)
- {
-   stackitem *temp= env->head;
-   if((env->head)==NULL) {
+   push_val(env, new_value);
-     printerr("Stack empty");
+   unprotect(new_value); unprotect(new_fvalue);
-     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 */
  }
  /* Print newline. */
- extern void nl(environment *env)
+ extern void nl()
  {
    printf("\n");
  }
- /* Prints the top element of the stack. */
+ /* Gets the type of a value */
- void print_h(stackitem *stack_head)
+ extern void type(environment *env)
  {
+   if(env->head->type==empty) {
-   if(stack_head==NULL) {
+     printerr("Too Few Arguments");
-     printerr("Stack empty");
+     env->err= 1;
      return;
    }
-   switch(stack_head->item->type) {
+   switch(CAR(env->head)->type){
+   case empty:
+     push_sym(env, "empty");
+     break;
    case integer:
-     printf("%d", stack_head->item->content.val);
+     push_sym(env, "integer");
+     break;
+   case tfloat:
+     push_sym(env, "float");
      break;
    case string:
-     printf("\"%s\"", (char*)stack_head->item->content.ptr);
+     push_sym(env, "string");
      break;
    case symb:
-     printf("'%s'", ((symbol *)(stack_head->item->content.ptr))->id);
+     push_sym(env, "symbol");
      break;
-   default:
+   case func:
-     printf("%p", (funcp)(stack_head->item->content.ptr));
+     push_sym(env, "function");
+     break;
+   case tcons:
+     push_sym(env, "pair");
+     break;
+   }
+   swap(env);
+   if (env->err) return;
+   toss(env);
+ }
+ /* Print a value */
+ void print_val(value *val, int noquote, stackitem *stack)
+ {
+   stackitem *titem, *tstack;
+   int depth;
+   switch(val->type) {
+   case empty:
+     printf("[]");
+     break;
+   case integer:
+     printf("%d", val->content.i);
+     break;
+   case tfloat:
+     printf("%f", val->content.f);
+     break;
+   case string:
+     if(noquote)
+       printf("%s", (char*)(val->content.ptr));
+     else
+       printf("\"%s\"", (char*)(val->content.ptr));
+     break;
+   case symb:
+     printf("%s", val->content.sym->id);
+     break;
+   case func:
+     printf("#<function %p>", (funcp)(val->content.ptr));
+     break;
+   case tcons:
+     printf("[ ");
+     tstack= stack;
+     do {
+       titem=malloc(sizeof(stackitem));
+       assert(titem != NULL);
+       titem->item=val;
+       titem->next=tstack;
+       tstack=titem;             /* Put it on the stack */
+       /* Search a stack of values being printed to see if we are already
+          printing this value */
+       titem=tstack;
+       depth=0;
+       while(titem != NULL && titem->item != CAR(val)){
+         titem=titem->next;
+         depth++;
+       }
+       if(titem != NULL){        /* If we found it on the stack, */
+         printf("#%d#", depth);  /* print a depth reference */
+       } else {
+         print_val(CAR(val), noquote, tstack);
+       }
+       val= CDR(val);
+       switch(val->type){
+       case empty:
+         break;
+       case tcons:
+         /* Search a stack of values being printed to see if we are already
+            printing this value */
+         titem=tstack;
+         depth=0;
+         while(titem != NULL && titem->item != val){
+           titem=titem->next;
+           depth++;
+         }
+         if(titem != NULL){      /* If we found it on the stack, */
+           printf(" . #%d#", depth); /* print a depth reference */
+         } else {
+           printf(" ");
+         }
+         break;
+       default:
+         printf(" . ");          /* Improper list */
+         print_val(val, noquote, tstack);
+       }
+     } while(val->type == tcons && titem == NULL);
+     titem=tstack;
+     while(titem != stack){
+       tstack=titem->next;
+       free(titem);
+       titem=tstack;
+     }
+     printf(" ]");
      break;
    }
  }
- extern void print_(environment *env) {
+ extern void print_(environment *env)
-   print_h(env->head);
+ {
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   print_val(CAR(env->head), 0, NULL);
+   nl();
  }
  /* Prints the top element of the stack and then discards it. */
  extern void print(environment *env)
  {
    print_(env);
+   if(env->err) return;
+   toss(env);
+ }
+ extern void princ_(environment *env)
+ {
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   print_val(CAR(env->head), 1, NULL);
+ }
+ /* Prints the top element of the stack and then discards it. */
+ extern void princ(environment *env)
+ {
+   princ_(env);
+   if(env->err) return;
    toss(env);
  }
  /* Only to be called by function printstack. */
- void print_st(stackitem *stack_head, long counter)
+ void print_st(value *stack_head, long counter)
  {
-   if(stack_head->next != NULL)
+   if(CDR(stack_head)->type != empty)
-     print_st(stack_head->next, counter+1);
+     print_st(CDR(stack_head), counter+1);
    printf("%ld: ", counter);
-   print_h(stack_head);
+   print_val(CAR(stack_head), 0, NULL);
    nl();
  }
  /* Prints the stack. */
  extern void printstack(environment *env)
  {
-   if(env->head != NULL) {
+   if(env->head->type == empty) {
-     print_st(env->head, 1);
+     printf("Stack Empty\n");
-     nl();
+     return;
-   } else {
-     printerr("Stack empty");
    }
+   print_st(env->head, 1);
  }
  /* Swap the two top elements on the stack. */
  extern void swap(environment *env)
  {
-   stackitem *temp= env->head;
+   value *temp= env->head;
-   if((env->head)==NULL) {
+   if(env->head->type == empty || CDR(env->head)->type == empty) {
-     printerr("Stack empty");
+     printerr("Too Few Arguments");
+     env->err=1;
      return;
    }
-   if(env->head->next==NULL) {
+   env->head= CDR(env->head);
-     printerr("Not enough arguments");
+   CDR(temp)= CDR(env->head);
-     return;
+   CDR(env->head)= temp;
-   }
-   env->head= env->head->next;
-   temp->next= env->head->next;
-   env->head->next= temp;
  }
- stackitem* copy(stackitem* in_item)
+ /* Rotate the first three elements on the stack. */
+ extern void rot(environment *env)
  {
-   stackitem *out_item= malloc(sizeof(stackitem));
+   value *temp= env->head;
-   memcpy(out_item, in_item, sizeof(stackitem));
+   if(env->head->type == empty || CDR(env->head)->type == empty
-   out_item->next= NULL;
+      || CDR(CDR(env->head))->type == empty) {
+     printerr("Too Few Arguments");
-   return out_item;
+     env->err= 1;
+     return;
+   }
+   env->head= CDR(CDR(env->head));
+   CDR(CDR(temp))= CDR(env->head);
+   CDR(env->head)= temp;
  }
  /* Recall a value from a symbol, if bound */
-Line 354 
 extern void rcl(environment *env)
+Line 685 
 extern void rcl(environment *env)
  {
    value *val;
-   if(env->head == NULL) {
+   if(env->head->type==empty) {
-     printerr("Stack empty");
+     printerr("Too Few Arguments");
+     env->err= 1;
      return;
    }
-   if(env->head->item->type!=symb) {
+   if(CAR(env->head)->type!=symb) {
-     printerr("Not a symbol");
+     printerr("Bad Argument Type");
+     env->err= 2;
      return;
    }
-   val=((symbol *)(env->head->item->content.ptr))->val;
+   val= CAR(env->head)->content.sym->val;
    if(val == NULL){
-     printerr("Unbound variable");
+     printerr("Unbound Variable");
+     env->err= 3;
      return;
    }
-   toss(env);            /* toss the symbol */
+   push_val(env, val);           /* Return the symbol's bound value */
-   push_val(&(env->head), val); /* Return its bound value */
+   swap(env);
+   if(env->err) return;
+   toss(env);                    /* toss the symbol */
+   if(env->err) return;
  }
  /* If the top element is a symbol, determine if it's bound to a
-Line 378 
 extern void rcl(environment *env)
+Line 716 
 extern void rcl(environment *env)
  extern void eval(environment *env)
  {
    funcp in_func;
-   value* val;
+   value* temp_val;
-   if(env->head==NULL) {
+   value* iterator;
-     printerr("Stack empty");
+  eval_start:
+   gc_maybe(env);
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
      return;
    }
-   /* if it's a symbol */
+   switch(CAR(env->head)->type) {
-   if(env->head->item->type==symb) {
+     /* if it's a symbol */
+   case symb:
-     /* If it's not bound to anything */
+     rcl(env);                   /* get its contents */
-     if (((symbol *)(env->head->item->content.ptr))->val == NULL) {
+     if(env->err) return;
-       printerr("Unbound variable");
+     if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
-       return;
+       goto eval_start;
      }
+     return;
+     /* If it's a lone function value, run it */
+   case func:
+     in_func= (funcp)(CAR(env->head)->content.ptr);
+     toss(env);
+     if(env->err) return;
+     return in_func(env);
+     /* If it's a list */
+   case tcons:
+     temp_val= CAR(env->head);
+     protect(temp_val);
+     toss(env); if(env->err) return;
+     iterator= temp_val;
-     /* If it contains a function */
+     while(iterator->type != empty) {
-     if (((symbol *)(env->head->item->content.ptr))->val->type == func) {
+       push_val(env, CAR(iterator));
-       in_func=
-         (funcp)(((symbol *)(env->head->item->content.ptr))->val->content.ptr);
+       if(CAR(env->head)->type==symb
-       toss(env);
+          && CAR(env->head)->content.sym->id[0]==';') {
-       (*in_func)(env);          /* Run the function */
+         toss(env);
-       return;
+         if(env->err) return;
-     } else {                    /* If it's not a function */
-       val=((symbol *)(env->head->item->content.ptr))->val;
+         if(CDR(iterator)->type == empty){
-       toss(env);                /* toss the symbol */
+           goto eval_start;
-       push_val(&(env->head), val); /* Return its bound value */
+         }
+         eval(env);
+         if(env->err) return;
+       }
+       if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
+         iterator= CDR(iterator);
+       else {
+         printerr("Bad Argument Type"); /* Improper list */
+         env->err= 2;
+         return;
+       }
      }
+     unprotect(temp_val);
+     return;
+   case empty:
+   case integer:
+   case tfloat:
+   case string:
+     return;
    }
+ }
-   /* If it's a lone function value, run it */
+ /* Reverse (flip) a list */
-   if(env->head->item->type==func) {
+ extern void rev(environment *env)
-     in_func= (funcp)(env->head->item->content.ptr);
+ {
-     toss(env);
+   value *old_head, *new_head, *item;
-     (*in_func)(env);
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type==empty)
+     return;                     /* Don't reverse an empty list */
+   if(CAR(env->head)->type!=tcons) {
+     printerr("Bad Argument Type");
+     env->err= 2;
      return;
    }
+   old_head= CAR(env->head);
+   new_head= new_val(env);
+   while(old_head->type != empty) {
+     item= old_head;
+     old_head= CDR(old_head);
+     CDR(item)= new_head;
+     new_head= item;
+   }
+   CAR(env->head)= new_head;
  }
  /* Make a list. */
  extern void pack(environment *env)
  {
-   void* delimiter;
+   value *iterator, *temp, *ending;
-   stackitem *iterator, *temp;
-   value *pack;
-   delimiter= env->head->item->content.ptr; /* Get delimiter */
+   ending=new_val(env);
-   toss(env);
    iterator= env->head;
+   if(iterator->type == empty
-   if(iterator==NULL || iterator->item->content.ptr==delimiter) {
+      || (CAR(iterator)->type==symb
-     temp= NULL;
+      && CAR(iterator)->content.sym->id[0]=='[')) {
+     temp= ending;
      toss(env);
    } else {
      /* Search for first delimiter */
-     while(iterator->next!=NULL
+     while(CDR(iterator)->type != empty
-           && iterator->next->item->content.ptr!=delimiter)
+           && (CAR(CDR(iterator))->type!=symb
-       iterator= iterator->next;
+            || CAR(CDR(iterator))->content.sym->id[0]!='['))
+       iterator= CDR(iterator);
      /* Extract list */
      temp= env->head;
-     env->head= iterator->next;
+     env->head= CDR(iterator);
-     iterator->next= NULL;
+     CDR(iterator)= ending;
-     if(env->head!=NULL)
+     if(env->head->type != empty)
        toss(env);
    }
    /* Push list */
-   pack= malloc(sizeof(value));
-   pack->type= list;
-   pack->content.ptr= temp;
-   pack->refcount= 1;
-   temp= malloc(sizeof(stackitem));
-   temp->item= pack;
-   push(&(env->head), temp);
+   push_val(env, temp);
- }
+   rev(env);
- /* Parse input. */
- int stack_read(environment *env, char *in_line)
- {
-   char *temp, *rest;
-   int itemp;
-   size_t inlength= strlen(in_line)+1;
-   int convert= 0;
-   static int non_eval_flag= 0;
-   temp= malloc(inlength);
-   rest= malloc(inlength);
-   do {
-     /* If string */
-     if((convert= sscanf(in_line, "\"%[^\"\n\r]\" %[^\n\r]", temp, rest))) {
-       push_cstring(&(env->head), temp);
-       break;
-     }
-     /* If integer */
-     if((convert= sscanf(in_line, "%d %[^\n\r]", &itemp, rest))) {
-       push_int(&(env->head), itemp);
-       break;
-     }
-     /* Escape ';' with '\' */
-     if((convert= sscanf(in_line, "\\%c%[^\n\r]", temp, rest))) {
-       temp[1]= '\0';
-       push_sym(env, temp);
-       break;
-     }
-     /* If symbol */
-     if((convert= sscanf(in_line, "%[^][ ;\n\r_]%[^\n\r]", temp, rest))) {
-         push_sym(env, temp);
-         break;
-     }
-     /* If single char */
-     if((convert= sscanf(in_line, "%c%[^\n\r]", temp, rest))) {
-       if(*temp==';') {
-         if(!non_eval_flag) {
-           eval(env);            /* Evaluate top element */
-           break;
-         }
-         push_sym(env, ";");
-         break;
-       }
-       if(*temp==']') {
-         push_sym(env, "[");
-         pack(env);
-         if(non_eval_flag!=0)
-           non_eval_flag--;
-         break;
-       }
-       if(*temp=='[') {
-         push_sym(env, "[");
-         non_eval_flag++;
-         break;
-       }
-     }
-   } while(0);
-   free(temp);
-   if(convert<2) {
-     free(rest);
-     return 0;
-   }
-   stack_read(env, rest);
-   free(rest);
-   return 1;
  }
  /* Relocate elements of the list on the stack. */
  extern void expand(environment *env)
  {
-   stackitem *temp, *new_head;
+   value *temp, *new_head;
    /* Is top element a list? */
-   if(env->head==NULL || env->head->item->type!=list) {
+   if(env->head->type==empty) {
-     printerr("Stack empty or not a list");
+     printerr("Too Few Arguments");
+     env->err= 1;
      return;
    }
+   if(CAR(env->head)->type!=tcons) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   rev(env);
+   if(env->err)
+     return;
    /* The first list element is the new stack head */
-   new_head= temp= env->head->item->content.ptr;
+   new_head= temp= CAR(env->head);
-   env->head->item->refcount++;
    toss(env);
    /* Find the end of the list */
-   while(temp->next!=NULL)
+   while(CDR(temp)->type != empty) {
-     temp= temp->next;
+     if (CDR(temp)->type == tcons)
+       temp= CDR(temp);
+     else {
+       printerr("Bad Argument Type"); /* Improper list */
+       env->err= 2;
+       return;
+     }
+   }
    /* Connect the tail of the list with the old stack head */
-   temp->next= env->head;
+   CDR(temp)= env->head;
    env->head= new_head;          /* ...and voila! */
  }
-Line 566 
 extern void expand(environment *env)
+Line 902 
 extern void expand(environment *env)
  extern void eq(environment *env)
  {
    void *left, *right;
-   int result;
-   if((env->head)==NULL || env->head->next==NULL) {
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
-     printerr("Not enough elements to compare");
+     printerr("Too Few Arguments");
+     env->err= 1;
      return;
    }
-   left= env->head->item->content.ptr;
+   left= CAR(env->head)->content.ptr;
-   swap(env);
+   right= CAR(CDR(env->head))->content.ptr;
-   right= env->head->item->content.ptr;
-   result= (left==right);
    toss(env); toss(env);
-   push_int(&(env->head), result);
+   push_int(env, left==right);
  }
  /* Negates the top element on the stack. */
-Line 587 
 extern void not(environment *env)
+Line 921 
 extern void not(environment *env)
  {
    int val;
-   if((env->head)==NULL || env->head->item->type!=integer) {
+   if(env->head->type==empty) {
-     printerr("Stack empty or element is not a integer");
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type!=integer) {
+     printerr("Bad Argument Type");
+     env->err= 2;
      return;
    }
-   val= env->head->item->content.val;
+   val= CAR(env->head)->content.i;
    toss(env);
-   push_int(&(env->head), !val);
+   push_int(env, !val);
  }
  /* Compares the two top elements on the stack and return 0 if they're the
-Line 611 
 extern void def(environment *env)
+Line 952 
 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
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
-      || env->head->item->type!=symb) {
+     printerr("Too Few Arguments");
-     printerr("Define what?");
+     env->err= 1;
      return;
    }
-   /* long names are a pain */
+   if(CAR(env->head)->type!=symb) {
-   sym=env->head->item->content.ptr;
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
-   /* if the symbol was bound to something else, throw it away */
+   /* long names are a pain */
-   if(sym->val != NULL)
+   sym= CAR(env->head)->content.ptr;
-     free_val(sym->val);
    /* Bind the symbol to the value */
-   sym->val= env->head->next->item;
+   sym->val= CAR(CDR(env->head));
-   sym->val->refcount++;         /* Increase the reference counter */
    toss(env); toss(env);
  }
-Line 634 
 extern void def(environment *env)
+Line 976 
 extern void def(environment *env)
  /* Quit stack. */
  extern void quit(environment *env)
  {
+   int i;
+   clear(env);
+   if (env->err) return;
+   for(i= 0; i<HASHTBLSIZE; i++) {
+     while(env->symbols[i]!= NULL) {
+       forget_sym(&(env->symbols[i]));
+     }
+     env->symbols[i]= NULL;
+   }
+   env->gc_limit= 0;
+   gc_maybe(env);
+   words(env);
+   if(env->free_string!=NULL)
+     free(env->free_string);
+ #ifdef __linux__
+   muntrace();
+ #endif
    exit(EXIT_SUCCESS);
  }
  /* Clear stack */
  extern void clear(environment *env)
  {
-   while(env->head!=NULL)
+   while(env->head->type != empty)
      toss(env);
  }
-Line 653 
 extern void words(environment *env)
+Line 1019 
 extern void words(environment *env)
    for(i= 0; i<HASHTBLSIZE; i++) {
      temp= env->symbols[i];
      while(temp!=NULL) {
+ #ifdef DEBUG
+       if (temp->val != NULL && temp->val->gc.flag.protect)
+         printf("(protected) ");
+ #endif /* DEBUG */
        printf("%s\n", temp->id);
        temp= temp->next;
      }
    }
  }
- int main()
+ /* Internal forget function */
+ void forget_sym(symbol **hash_entry)
+ {
+   symbol *temp;
+   temp= *hash_entry;
+   *hash_entry= (*hash_entry)->next;
+   free(temp->id);
+   free(temp);
+ }
+ /* Forgets a symbol (remove it from the hash table) */
+ extern void forget(environment *env)
+ {
+   char* sym_id;
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type!=symb) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   sym_id= CAR(env->head)->content.sym->id;
+   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);
+ }
+ int main(int argc, char **argv)
  {
    environment myenv;
-   char in_string[100];
+   int c;                        /* getopt option character */
+ #ifdef __linux__
+   mtrace();
+ #endif
    init_env(&myenv);
-   printf("okidok\n ");
+   myenv.interactive = isatty(STDIN_FILENO) && isatty(STDOUT_FILENO);
+   while ((c = getopt (argc, argv, "i")) != -1)
+     switch (c)
+       {
+       case 'i':
+         myenv.interactive = 1;
+         break;
+       case '?':
+         fprintf (stderr,
+                  "Unknown option character '\\x%x'.\n",
+                  optopt);
+         return EX_USAGE;
+       default:
+         abort ();
+       }
+   if (optind < argc) {
+     myenv.interactive = 0;
+     myenv.inputstream= fopen(argv[optind], "r");
+     if(myenv.inputstream== NULL) {
+       perror(argv[0]);
+       exit (EX_NOINPUT);
+     }
+   }
-   while(fgets(in_string, 100, stdin) != NULL) {
+   if(myenv.interactive) {
-     stack_read(&myenv, in_string);
+     printf("Stack version $Revision$\n\
-     printf("okidok\n ");
+ Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
+ Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
+ This is free software, and you are welcome to redistribute it\n\
+ under certain conditions; type 'copying;' for details.\n");
    }
-   exit(EXIT_SUCCESS);
+   while(1) {
+     if(myenv.in_string==NULL) {
+       if (myenv.interactive) {
+         if(myenv.err) {
+           printf("(error %d)\n", myenv.err);
+         }
+         nl();
+         printstack(&myenv);
+         printf("> ");
+       }
+       myenv.err=0;
+     }
+     sx_72656164(&myenv);        /* "read" */
+     if (myenv.err==4) {         /* EOF */
+       myenv.err=0;
+       quit(&myenv);
+     } else if(myenv.head->type!=empty
+               && CAR(myenv.head)->type==symb
+               && CAR(myenv.head)->content.sym->id[0]
+               ==';') {
+       toss(&myenv);             /* No error check in main */
+       eval(&myenv);
+     }
+     gc_maybe(&myenv);
+   }
+   quit(&myenv);
+   return EXIT_FAILURE;
+ }
+ /* "+" */
+ extern void sx_2b(environment *env)
+ {
+   int a, b;
+   float fa, fb;
+   size_t len;
+   char* new_string;
+   value *a_val, *b_val;
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type==string
+      && CAR(CDR(env->head))->type==string) {
+     a_val= CAR(env->head);
+     b_val= CAR(CDR(env->head));
+     protect(a_val); protect(b_val);
+     toss(env); if(env->err) return;
+     toss(env); if(env->err) return;
+     len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
+     new_string= malloc(len);
+     assert(new_string != NULL);
+     strcpy(new_string, b_val->content.ptr);
+     strcat(new_string, a_val->content.ptr);
+     push_cstring(env, new_string);
+     unprotect(a_val); unprotect(b_val);
+     free(new_string);
+     return;
+   }
+   if(CAR(env->head)->type==integer
+      && CAR(CDR(env->head))->type==integer) {
+     a= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     b= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     push_int(env, b+a);
+     return;
+   }
+   if(CAR(env->head)->type==tfloat
+      && CAR(CDR(env->head))->type==tfloat) {
+     fa= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     fb= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb+fa);
+     return;
+   }
+   if(CAR(env->head)->type==tfloat
+      && CAR(CDR(env->head))->type==integer) {
+     fa= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     b= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     push_float(env, b+fa);
+     return;
+   }
+   if(CAR(env->head)->type==integer
+      && CAR(CDR(env->head))->type==tfloat) {
+     a= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     fb= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb+a);
+     return;
+   }
+   printerr("Bad Argument Type");
+   env->err=2;
+ }
+ /* "-" */
+ extern void sx_2d(environment *env)
+ {
+   int a, b;
+   float fa, fb;
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   if(CAR(env->head)->type==integer
+      && CAR(CDR(env->head))->type==integer) {
+     a= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     b= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     push_int(env, b-a);
+     return;
+   }
+   if(CAR(env->head)->type==tfloat
+      && CAR(CDR(env->head))->type==tfloat) {
+     fa= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     fb= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb-fa);
+     return;
+   }
+   if(CAR(env->head)->type==tfloat
+      && CAR(CDR(env->head))->type==integer) {
+     fa= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     b= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     push_float(env, b-fa);
+     return;
+   }
+   if(CAR(env->head)->type==integer
+      && CAR(CDR(env->head))->type==tfloat) {
+     a= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     fb= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb-a);
+     return;
+   }
+   printerr("Bad Argument Type");
+   env->err=2;
+ }
+ /* ">" */
+ extern void sx_3e(environment *env)
+ {
+   int a, b;
+   float fa, fb;
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type==integer
+      && CAR(CDR(env->head))->type==integer) {
+     a= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     b= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     push_int(env, b>a);
+     return;
+   }
+   if(CAR(env->head)->type==tfloat
+      && CAR(CDR(env->head))->type==tfloat) {
+     fa= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     fb= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     push_int(env, fb>fa);
+     return;
+   }
+   if(CAR(env->head)->type==tfloat
+      && CAR(CDR(env->head))->type==integer) {
+     fa= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     b= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     push_int(env, b>fa);
+     return;
+   }
+   if(CAR(env->head)->type==integer
+      && CAR(CDR(env->head))->type==tfloat) {
+     a= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     fb= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     push_int(env, fb>a);
+     return;
+   }
+   printerr("Bad Argument Type");
+   env->err= 2;
+ }
+ /* "<" */
+ extern void sx_3c(environment *env)
+ {
+   swap(env); if(env->err) return;
+   sx_3e(env);
+ }
+ /* "<=" */
+ extern void sx_3c3d(environment *env)
+ {
+   sx_3e(env); if(env->err) return;
+   not(env);
+ }
+ /* ">=" */
+ extern void sx_3e3d(environment *env)
+ {
+   sx_3c(env); if(env->err) return;
+   not(env);
+ }
+ /* Return copy of a value */
+ value *copy_val(environment *env, value *old_value)
+ {
+   value *new_value;
+   if(old_value==NULL)
+     return NULL;
+   protect(old_value);
+   new_value= new_val(env);
+   new_value->type= old_value->type;
+   switch(old_value->type){
+   case tfloat:
+   case integer:
+   case func:
+   case symb:
+   case empty:
+     new_value->content= old_value->content;
+     break;
+   case string:
+     (char *)(new_value->content.ptr)=
+       strdup((char *)(old_value->content.ptr));
+     break;
+   case tcons:
+     new_value->content.c= malloc(sizeof(pair));
+     assert(new_value->content.c!=NULL);
+     env->gc_count += sizeof(pair);
+     CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
+     CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
+     break;
+   }
+   unprotect(old_value);
+   return new_value;
+ }
+ /* "dup"; duplicates an item on the stack */
+ extern void sx_647570(environment *env)
+ {
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   push_val(env, copy_val(env, CAR(env->head)));
+ }
+ /* "if", If-Then */
+ extern void sx_6966(environment *env)
+ {
+   int truth;
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(CDR(env->head))->type != integer) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   swap(env);
+   if(env->err) return;
+   truth= CAR(env->head)->content.i;
+   toss(env);
+   if(env->err) return;
+   if(truth)
+     eval(env);
+   else
+     toss(env);
+ }
+ /* If-Then-Else */
+ extern void ifelse(environment *env)
+ {
+   int truth;
+   if(env->head->type==empty || CDR(env->head)->type==empty
+      || CDR(CDR(env->head))->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(CDR(CDR(env->head)))->type!=integer) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   rot(env);
+   if(env->err) return;
+   truth= CAR(env->head)->content.i;
+   toss(env);
+   if(env->err) return;
+   if(!truth)
+     swap(env);
+   if(env->err) return;
+   toss(env);
+   if(env->err) return;
+   eval(env);
+ }
+ extern void sx_656c7365(environment *env)
+ {
+   if(env->head->type==empty || CDR(env->head)->type==empty
+      || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
+      || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(CDR(env->head))->type!=symb
+      || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
+      || CAR(CDR(CDR(CDR(env->head))))->type!=symb
+      || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   swap(env); toss(env); rot(env); toss(env);
+   ifelse(env);
+ }
+ extern void then(environment *env)
+ {
+   if(env->head->type==empty || CDR(env->head)->type==empty
+      || CDR(CDR(env->head))->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(CDR(env->head))->type!=symb
+      || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   swap(env); toss(env);
+   sx_6966(env);
+ }
+ /* "while" */
+ extern void sx_7768696c65(environment *env)
+ {
+   int truth;
+   value *loop, *test;
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   loop= CAR(env->head);
+   protect(loop);
+   toss(env); if(env->err) return;
+   test= CAR(env->head);
+   protect(test);
+   toss(env); if(env->err) return;
+   do {
+     push_val(env, test);
+     eval(env);
+     if(CAR(env->head)->type != integer) {
+       printerr("Bad Argument Type");
+       env->err= 2;
+       return;
+     }
+     truth= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     if(truth) {
+       push_val(env, loop);
+       eval(env);
+     } else {
+       toss(env);
+     }
+   } while(truth);
+   unprotect(loop); unprotect(test);
+ }
+ /* "for"; for-loop */
+ extern void sx_666f72(environment *env)
+ {
+   value *loop;
+   int foo1, foo2;
+   if(env->head->type==empty || CDR(env->head)->type==empty
+      || CDR(CDR(env->head))->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(CDR(env->head))->type!=integer
+      || CAR(CDR(CDR(env->head)))->type!=integer) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   loop= CAR(env->head);
+   protect(loop);
+   toss(env); if(env->err) return;
+   foo2= CAR(env->head)->content.i;
+   toss(env); if(env->err) return;
+   foo1= CAR(env->head)->content.i;
+   toss(env); if(env->err) return;
+   if(foo1<=foo2) {
+     while(foo1<=foo2) {
+       push_int(env, foo1);
+       push_val(env, loop);
+       eval(env); if(env->err) return;
+       foo1++;
+     }
+   } else {
+     while(foo1>=foo2) {
+       push_int(env, foo1);
+       push_val(env, loop);
+       eval(env); if(env->err) return;
+       foo1--;
+     }
+   }
+   unprotect(loop);
+ }
+ /* Variant of for-loop */
+ extern void foreach(environment *env)
+ {
+   value *loop, *foo;
+   value *iterator;
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(CDR(env->head))->type!=tcons) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   loop= CAR(env->head);
+   protect(loop);
+   toss(env); if(env->err) return;
+   foo= CAR(env->head);
+   protect(foo);
+   toss(env); if(env->err) return;
+   iterator= foo;
+   while(iterator->type!=empty) {
+     push_val(env, CAR(iterator));
+     push_val(env, loop);
+     eval(env); if(env->err) return;
+     if (iterator->type == tcons){
+       iterator= CDR(iterator);
+     } else {
+       printerr("Bad Argument Type"); /* Improper list */
+       env->err= 2;
+       break;
+     }
+   }
+   unprotect(loop); unprotect(foo);
+ }
+ /* "to" */
+ extern void to(environment *env)
+ {
+   int ending, start, i;
+   value *iterator, *temp, *end;
+   end= new_val(env);
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type!=integer
+      || CAR(CDR(env->head))->type!=integer) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   ending= CAR(env->head)->content.i;
+   toss(env); if(env->err) return;
+   start= CAR(env->head)->content.i;
+   toss(env); if(env->err) return;
+   push_sym(env, "[");
+   if(ending>=start) {
+     for(i= ending; i>=start; i--)
+       push_int(env, i);
+   } else {
+     for(i= ending; i<=start; i++)
+       push_int(env, i);
+   }
+   iterator= env->head;
+   if(iterator->type==empty
+      || (CAR(iterator)->type==symb
+          && CAR(iterator)->content.sym->id[0]=='[')) {
+     temp= end;
+     toss(env);
+   } else {
+     /* Search for first delimiter */
+     while(CDR(iterator)->type!=empty
+           && (CAR(CDR(iterator))->type!=symb
+               || CAR(CDR(iterator))->content.sym->id[0]!='['))
+       iterator= CDR(iterator);
+     /* Extract list */
+     temp= env->head;
+     env->head= CDR(iterator);
+     CDR(iterator)= end;
+     if(env->head->type!=empty)
+       toss(env);
+   }
+   /* Push list */
+   push_val(env, temp);
+ }
+ /* Read a string */
+ extern void readline(environment *env)
+ {
+   char in_string[101];
+   if(fgets(in_string, 100, env->inputstream)==NULL)
+     push_cstring(env, "");
+   else
+     push_cstring(env, in_string);
+ }
+ /* "read"; Read a value and place on stack */
+ extern void sx_72656164(environment *env)
+ {
+   const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
+   const char strform[]= "\"%[^\"]\"%n";
+   const char intform[]= "%i%n";
+   const char fltform[]= "%f%n";
+   const char blankform[]= "%*[ \t]%n";
+   const char ebrackform[]= "]%n";
+   const char semicform[]= ";%n";
+   const char bbrackform[]= "[%n";
+   int itemp, readlength= -1;
+   int count= -1;
+   float ftemp;
+   static int depth= 0;
+   char *match;
+   size_t inlength;
+   if(env->in_string==NULL) {
+     if(depth > 0 && env->interactive) {
+       printf("]> ");
+     }
+     readline(env); if(env->err) return;
+     if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
+       env->err= 4;              /* "" means EOF */
+       return;
+     }
+     env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
+     assert(env->in_string != NULL);
+     env->free_string= env->in_string; /* Save the original pointer */
+     strcpy(env->in_string, CAR(env->head)->content.ptr);
+     toss(env); if(env->err) return;
+   }
+   inlength= strlen(env->in_string)+1;
+   match= malloc(inlength);
+   assert(match != NULL);
+   if(sscanf(env->in_string, blankform, &readlength) != EOF
+      && readlength != -1) {
+     ;
+   } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
+             && readlength != -1) {
+     if(sscanf(env->in_string, intform, &itemp, &count) != EOF
+        && count==readlength) {
+       push_int(env, itemp);
+     } else {
+       push_float(env, ftemp);
+     }
+   } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
+             && readlength != -1) {
+     push_cstring(env, "");
+   } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
+             && readlength != -1) {
+     push_cstring(env, match);
+   } else if(sscanf(env->in_string, symbform, match, &readlength) != EOF
+             && readlength != -1) {
+     push_sym(env, match);
+   } else if(sscanf(env->in_string, ebrackform, &readlength) != EOF
+             && readlength != -1) {
+     pack(env); if(env->err) return;
+     if(depth != 0) depth--;
+   } else if(sscanf(env->in_string, semicform, &readlength) != EOF
+             && readlength != -1) {
+     push_sym(env, ";");
+   } else if(sscanf(env->in_string, bbrackform, &readlength) != EOF
+             && readlength != -1) {
+     push_sym(env, "[");
+     depth++;
+   } else {
+     free(env->free_string);
+     env->in_string = env->free_string = NULL;
+   }
+   if (env->in_string != NULL) {
+     env->in_string += readlength;
+   }
+   free(match);
+   if(depth)
+     return sx_72656164(env);
+ }
+ #ifdef __linux__
+ extern void beep(environment *env)
+ {
+   int freq, dur, period, ticks;
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type!=integer
+      || CAR(CDR(env->head))->type!=integer) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   dur= CAR(env->head)->content.i;
+   toss(env);
+   freq= CAR(env->head)->content.i;
+   toss(env);
+   period= 1193180/freq;         /* convert freq from Hz to period
+                                    length */
+   ticks= dur*.001193180;        /* convert duration from µseconds to
+                                    timer ticks */
+ /*    ticks=dur/1000; */
+       /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
+   switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
+   case 0:
+     usleep(dur);
+     return;
+   case -1:
+     perror("beep");
+     env->err= 5;
+     return;
+   default:
+     abort();
+   }
+ }
+ #endif /* __linux__ */
+ /* "wait" */
+ extern void sx_77616974(environment *env)
+ {
+   int dur;
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type!=integer) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   dur= CAR(env->head)->content.i;
+   toss(env);
+   usleep(dur);
+ }
+ extern void copying(environment *env)
+ {
+   printf("                  GNU GENERAL PUBLIC LICENSE\n\
+                        Version 2, June 1991\n\
+ \n\
+  Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
+Temple Place, Suite 330, Boston, MA  02111-1307  USA\n\
+  Everyone is permitted to copy and distribute verbatim copies\n\
+  of this license document, but changing it is not allowed.\n\
+ \n\
+                             Preamble\n\
+ \n\
+   The licenses for most software are designed to take away your\n\
+ freedom to share and change it.  By contrast, the GNU General Public\n\
+ License is intended to guarantee your freedom to share and change free\n\
+ software--to make sure the software is free for all its users.  This\n\
+ General Public License applies to most of the Free Software\n\
+ Foundation's software and to any other program whose authors commit to\n\
+ using it.  (Some other Free Software Foundation software is covered by\n\
+ the GNU Library General Public License instead.)  You can apply it to\n\
+ your programs, too.\n\
+ \n\
+   When we speak of free software, we are referring to freedom, not\n\
+ price.  Our General Public Licenses are designed to make sure that you\n\
+ have the freedom to distribute copies of free software (and charge for\n\
+ this service if you wish), that you receive source code or can get it\n\
+ if you want it, that you can change the software or use pieces of it\n\
+ in new free programs; and that you know you can do these things.\n\
+ \n\
+   To protect your rights, we need to make restrictions that forbid\n\
+ anyone to deny you these rights or to ask you to surrender the rights.\n\
+ These restrictions translate to certain responsibilities for you if you\n\
+ distribute copies of the software, or if you modify it.\n\
+ \n\
+   For example, if you distribute copies of such a program, whether\n\
+ gratis or for a fee, you must give the recipients all the rights that\n\
+ you have.  You must make sure that they, too, receive or can get the\n\
+ source code.  And you must show them these terms so they know their\n\
+ rights.\n\
+ \n\
+   We protect your rights with two steps: (1) copyright the software, and\n\
+ (2) offer you this license which gives you legal permission to copy,\n\
+ distribute and/or modify the software.\n\
+ \n\
+   Also, for each author's protection and ours, we want to make certain\n\
+ that everyone understands that there is no warranty for this free\n\
+ software.  If the software is modified by someone else and passed on, we\n\
+ want its recipients to know that what they have is not the original, so\n\
+ that any problems introduced by others will not reflect on the original\n\
+ authors' reputations.\n\
+ \n\
+   Finally, any free program is threatened constantly by software\n\
+ patents.  We wish to avoid the danger that redistributors of a free\n\
+ program will individually obtain patent licenses, in effect making the\n\
+ program proprietary.  To prevent this, we have made it clear that any\n\
+ patent must be licensed for everyone's free use or not licensed at all.\n\
+ \n\
+   The precise terms and conditions for copying, distribution and\n\
+ modification follow.\n\
+ \n\
+                     GNU GENERAL PUBLIC LICENSE\n\
+    TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION\n\
+ \n\
+. This License applies to any program or other work which contains\n\
+ a notice placed by the copyright holder saying it may be distributed\n\
+ under the terms of this General Public License.  The \"Program\", below,\n\
+ refers to any such program or work, and a \"work based on the Program\"\n\
+ means either the Program or any derivative work under copyright law:\n\
+ that is to say, a work containing the Program or a portion of it,\n\
+ either verbatim or with modifications and/or translated into another\n\
+ language.  (Hereinafter, translation is included without limitation in\n\
+ the term \"modification\".)  Each licensee is addressed as \"you\".\n\
+ \n\
+ Activities other than copying, distribution and modification are not\n\
+ covered by this License; they are outside its scope.  The act of\n\
+ running the Program is not restricted, and the output from the Program\n\
+ is covered only if its contents constitute a work based on the\n\
+ Program (independent of having been made by running the Program).\n\
+ Whether that is true depends on what the Program does.\n\
+ \n\
+. You may copy and distribute verbatim copies of the Program's\n\
+ source code as you receive it, in any medium, provided that you\n\
+ conspicuously and appropriately publish on each copy an appropriate\n\
+ copyright notice and disclaimer of warranty; keep intact all the\n\
+ notices that refer to this License and to the absence of any warranty;\n\
+ and give any other recipients of the Program a copy of this License\n\
+ along with the Program.\n\
+ \n\
+ You may charge a fee for the physical act of transferring a copy, and\n\
+ you may at your option offer warranty protection in exchange for a fee.\n\
+ \n\
+. You may modify your copy or copies of the Program or any portion\n\
+ of it, thus forming a work based on the Program, and copy and\n\
+ distribute such modifications or work under the terms of Section 1\n\
+ above, provided that you also meet all of these conditions:\n\
+ \n\
+     a) You must cause the modified files to carry prominent notices\n\
+     stating that you changed the files and the date of any change.\n\
+ \n\
+     b) You must cause any work that you distribute or publish, that in\n\
+     whole or in part contains or is derived from the Program or any\n\
+     part thereof, to be licensed as a whole at no charge to all third\n\
+     parties under the terms of this License.\n\
+ \n\
+     c) If the modified program normally reads commands interactively\n\
+     when run, you must cause it, when started running for such\n\
+     interactive use in the most ordinary way, to print or display an\n\
+     announcement including an appropriate copyright notice and a\n\
+     notice that there is no warranty (or else, saying that you provide\n\
+     a warranty) and that users may redistribute the program under\n\
+     these conditions, and telling the user how to view a copy of this\n\
+     License.  (Exception: if the Program itself is interactive but\n\
+     does not normally print such an announcement, your work based on\n\
+     the Program is not required to print an announcement.)\n\
+ \n\
+ These requirements apply to the modified work as a whole.  If\n\
+ identifiable sections of that work are not derived from the Program,\n\
+ and can be reasonably considered independent and separate works in\n\
+ themselves, then this License, and its terms, do not apply to those\n\
+ sections when you distribute them as separate works.  But when you\n\
+ distribute the same sections as part of a whole which is a work based\n\
+ on the Program, the distribution of the whole must be on the terms of\n\
+ this License, whose permissions for other licensees extend to the\n\
+ entire whole, and thus to each and every part regardless of who wrote it.\n\
+ \n\
+ Thus, it is not the intent of this section to claim rights or contest\n\
+ your rights to work written entirely by you; rather, the intent is to\n\
+ exercise the right to control the distribution of derivative or\n\
+ collective works based on the Program.\n\
+ \n\
+ In addition, mere aggregation of another work not based on the Program\n\
+ with the Program (or with a work based on the Program) on a volume of\n\
+ a storage or distribution medium does not bring the other work under\n\
+ the scope of this License.\n\
+ \n\
+. You may copy and distribute the Program (or a work based on it,\n\
+ under Section 2) in object code or executable form under the terms of\n\
+ Sections 1 and 2 above provided that you also do one of the following:\n\
+ \n\
+     a) Accompany it with the complete corresponding machine-readable\n\
+     source code, which must be distributed under the terms of Sections\n\
+and 2 above on a medium customarily used for software interchange; or,\n\
+ \n\
+     b) Accompany it with a written offer, valid for at least three\n\
+     years, to give any third party, for a charge no more than your\n\
+     cost of physically performing source distribution, a complete\n\
+     machine-readable copy of the corresponding source code, to be\n\
+     distributed under the terms of Sections 1 and 2 above on a medium\n\
+     customarily used for software interchange; or,\n\
+ \n\
+     c) Accompany it with the information you received as to the offer\n\
+     to distribute corresponding source code.  (This alternative is\n\
+     allowed only for noncommercial distribution and only if you\n\
+     received the program in object code or executable form with such\n\
+     an offer, in accord with Subsection b above.)\n\
+ \n\
+ The source code for a work means the preferred form of the work for\n\
+ making modifications to it.  For an executable work, complete source\n\
+ code means all the source code for all modules it contains, plus any\n\
+ associated interface definition files, plus the scripts used to\n\
+ control compilation and installation of the executable.  However, as a\n\
+ special exception, the source code distributed need not include\n\
+ anything that is normally distributed (in either source or binary\n\
+ form) with the major components (compiler, kernel, and so on) of the\n\
+ operating system on which the executable runs, unless that component\n\
+ itself accompanies the executable.\n\
+ \n\
+ If distribution of executable or object code is made by offering\n\
+ access to copy from a designated place, then offering equivalent\n\
+ access to copy the source code from the same place counts as\n\
+ distribution of the source code, even though third parties are not\n\
+ compelled to copy the source along with the object code.\n\
+ \n\
+. You may not copy, modify, sublicense, or distribute the Program\n\
+ except as expressly provided under this License.  Any attempt\n\
+ otherwise to copy, modify, sublicense or distribute the Program is\n\
+ void, and will automatically terminate your rights under this License.\n\
+ However, parties who have received copies, or rights, from you under\n\
+ this License will not have their licenses terminated so long as such\n\
+ parties remain in full compliance.\n\
+ \n\
+. You are not required to accept this License, since you have not\n\
+ signed it.  However, nothing else grants you permission to modify or\n\
+ distribute the Program or its derivative works.  These actions are\n\
+ prohibited by law if you do not accept this License.  Therefore, by\n\
+ modifying or distributing the Program (or any work based on the\n\
+ Program), you indicate your acceptance of this License to do so, and\n\
+ all its terms and conditions for copying, distributing or modifying\n\
+ the Program or works based on it.\n\
+ \n\
+. Each time you redistribute the Program (or any work based on the\n\
+ Program), the recipient automatically receives a license from the\n\
+ original licensor to copy, distribute or modify the Program subject to\n\
+ these terms and conditions.  You may not impose any further\n\
+ restrictions on the recipients' exercise of the rights granted herein.\n\
+ You are not responsible for enforcing compliance by third parties to\n\
+ this License.\n\
+ \n\
+. If, as a consequence of a court judgment or allegation of patent\n\
+ infringement or for any other reason (not limited to patent issues),\n\
+ conditions are imposed on you (whether by court order, agreement or\n\
+ otherwise) that contradict the conditions of this License, they do not\n\
+ excuse you from the conditions of this License.  If you cannot\n\
+ distribute so as to satisfy simultaneously your obligations under this\n\
+ License and any other pertinent obligations, then as a consequence you\n\
+ may not distribute the Program at all.  For example, if a patent\n\
+ license would not permit royalty-free redistribution of the Program by\n\
+ all those who receive copies directly or indirectly through you, then\n\
+ the only way you could satisfy both it and this License would be to\n\
+ refrain entirely from distribution of the Program.\n\
+ \n\
+ If any portion of this section is held invalid or unenforceable under\n\
+ any particular circumstance, the balance of the section is intended to\n\
+ apply and the section as a whole is intended to apply in other\n\
+ circumstances.\n\
+ \n\
+ It is not the purpose of this section to induce you to infringe any\n\
+ patents or other property right claims or to contest validity of any\n\
+ such claims; this section has the sole purpose of protecting the\n\
+ integrity of the free software distribution system, which is\n\
+ implemented by public license practices.  Many people have made\n\
+ generous contributions to the wide range of software distributed\n\
+ through that system in reliance on consistent application of that\n\
+ system; it is up to the author/donor to decide if he or she is willing\n\
+ to distribute software through any other system and a licensee cannot\n\
+ impose that choice.\n\
+ \n\
+ This section is intended to make thoroughly clear what is believed to\n\
+ be a consequence of the rest of this License.\n\
+ \n\
+. If the distribution and/or use of the Program is restricted in\n\
+ certain countries either by patents or by copyrighted interfaces, the\n\
+ original copyright holder who places the Program under this License\n\
+ may add an explicit geographical distribution limitation excluding\n\
+ those countries, so that distribution is permitted only in or among\n\
+ countries not thus excluded.  In such case, this License incorporates\n\
+ the limitation as if written in the body of this License.\n\
+ \n\
+. The Free Software Foundation may publish revised and/or new versions\n\
+ of the General Public License from time to time.  Such new versions will\n\
+ be similar in spirit to the present version, but may differ in detail to\n\
+ address new problems or concerns.\n\
+ \n\
+ Each version is given a distinguishing version number.  If the Program\n\
+ specifies a version number of this License which applies to it and \"any\n\
+ later version\", you have the option of following the terms and conditions\n\
+ either of that version or of any later version published by the Free\n\
+ Software Foundation.  If the Program does not specify a version number of\n\
+ this License, you may choose any version ever published by the Free Software\n\
+ Foundation.\n\
+ \n\
+. If you wish to incorporate parts of the Program into other free\n\
+ programs whose distribution conditions are different, write to the author\n\
+ to ask for permission.  For software which is copyrighted by the Free\n\
+ Software Foundation, write to the Free Software Foundation; we sometimes\n\
+ make exceptions for this.  Our decision will be guided by the two goals\n\
+ of preserving the free status of all derivatives of our free software and\n\
+ of promoting the sharing and reuse of software generally.\n");
+ }
+ extern void warranty(environment *env)
+ {
+   printf("                          NO WARRANTY\n\
+ \n\
+. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\
+ FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN\n\
+ OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES\n\
+ PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED\n\
+ OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF\n\
+ MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS\n\
+ TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE\n\
+ PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,\n\
+ REPAIR OR CORRECTION.\n\
+ \n\
+. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING\n\
+ WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR\n\
+ REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,\n\
+ INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING\n\
+ OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED\n\
+ TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY\n\
+ YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER\n\
+ PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE\n\
+ POSSIBILITY OF SUCH DAMAGES.\n");
+ }
+ /* "*" */
+ extern void sx_2a(environment *env)
+ {
+   int a, b;
+   float fa, fb;
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type==integer
+      && CAR(CDR(env->head))->type==integer) {
+     a= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     b= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     push_int(env, b*a);
+     return;
+   }
+   if(CAR(env->head)->type==tfloat
+      && CAR(CDR(env->head))->type==tfloat) {
+     fa= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     fb= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb*fa);
+     return;
+   }
+   if(CAR(env->head)->type==tfloat
+      && CAR(CDR(env->head))->type==integer) {
+     fa= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     b= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     push_float(env, b*fa);
+     return;
+   }
+   if(CAR(env->head)->type==integer
+      && CAR(CDR(env->head))->type==tfloat) {
+     a= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     fb= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb*a);
+     return;
+   }
+   printerr("Bad Argument Type");
+   env->err= 2;
+ }
+ /* "/" */
+ extern void sx_2f(environment *env)
+ {
+   int a, b;
+   float fa, fb;
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type==integer
+      && CAR(CDR(env->head))->type==integer) {
+     a= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     b= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     push_float(env, b/a);
+     return;
+   }
+   if(CAR(env->head)->type==tfloat
+      && CAR(CDR(env->head))->type==tfloat) {
+     fa= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     fb= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb/fa);
+     return;
+   }
+   if(CAR(env->head)->type==tfloat
+      && CAR(CDR(env->head))->type==integer) {
+     fa= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     b= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     push_float(env, b/fa);
+     return;
+   }
+   if(CAR(env->head)->type==integer
+      && CAR(CDR(env->head))->type==tfloat) {
+     a= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     fb= CAR(env->head)->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb/a);
+     return;
+   }
+   printerr("Bad Argument Type");
+   env->err= 2;
+ }
+ /* "mod" */
+ extern void mod(environment *env)
+ {
+   int a, b;
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type==integer
+      && CAR(CDR(env->head))->type==integer) {
+     a= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     b= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     push_int(env, b%a);
+     return;
+   }
+   printerr("Bad Argument Type");
+   env->err= 2;
+ }
+ /* "div" */
+ extern void sx_646976(environment *env)
+ {
+   int a, b;
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type==integer
+      && CAR(CDR(env->head))->type==integer) {
+     a= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     b= CAR(env->head)->content.i;
+     toss(env); if(env->err) return;
+     push_int(env, (int)b/a);
+     return;
+   }
+   printerr("Bad Argument Type");
+   env->err= 2;
+ }
+ extern void setcar(environment *env)
+ {
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CDR(env->head)->type!=tcons) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   CAR(CAR(CDR(env->head)))=CAR(env->head);
+   toss(env);
+ }
+ extern void setcdr(environment *env)
+ {
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CDR(env->head)->type!=tcons) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   CDR(CAR(CDR(env->head)))=CAR(env->head);
+   toss(env);
+ }
+ extern void car(environment *env)
+ {
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type!=tcons) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   CAR(env->head)=CAR(CAR(env->head));
+ }
+ extern void cdr(environment *env)
+ {
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type!=tcons) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   CAR(env->head)=CDR(CAR(env->head));
+ }
+ extern void cons(environment *env)
+ {
+   value *val;
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   val=new_val(env);
+   val->content.c= malloc(sizeof(pair));
+   assert(val->content.c!=NULL);
+   env->gc_count += sizeof(pair);
+   val->type=tcons;
+   CAR(val)= CAR(CDR(env->head));
+   CDR(val)= CAR(env->head);
+   push_val(env, val);
+   swap(env); if(env->err) return;
+   toss(env); if(env->err) return;
+   swap(env); if(env->err) return;
+   toss(env); if(env->err) return;
+ }
+ /*  2: 3                        =>                */
+ /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
+ extern void assq(environment *env)
+ {
+   assocgen(env, eq);
+ }
+ /* General assoc function */
+ void assocgen(environment *env, funcp eqfunc)
+ {
+   value *key, *item;
+   /* Needs two values on the stack, the top one must be an association
+      list */
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type!=tcons) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   key=CAR(CDR(env->head));
+   item=CAR(env->head);
+   while(item->type == tcons){
+     if(CAR(item)->type != tcons){
+       printerr("Bad Argument Type");
+       env->err= 2;
+       return;
+     }
+     push_val(env, key);
+     push_val(env, CAR(CAR(item)));
+     eqfunc(env); if(env->err) return;
+     /* Check the result of 'eqfunc' */
+     if(env->head->type==empty) {
+       printerr("Too Few Arguments");
+       env->err= 1;
+     return;
+     }
+     if(CAR(env->head)->type!=integer) {
+       printerr("Bad Argument Type");
+       env->err= 2;
+       return;
+     }
+     if(CAR(env->head)->content.i){
+       toss(env); if(env->err) return;
+       break;
+     }
+     toss(env); if(env->err) return;
+     if(item->type!=tcons) {
+       printerr("Bad Argument Type");
+       env->err= 2;
+       return;
+     }
+     item=CDR(item);
+   }
+   if(item->type == tcons){      /* A match was found */
+     push_val(env, CAR(item));
+   } else {
+     push_int(env, 0);
+   }
+   swap(env); if(env->err) return;
+   toss(env); if(env->err) return;
+   swap(env); if(env->err) return;
+   toss(env);
  }

 Legend:



Removed from v.1.33
 


changed lines


 
Added in v.1.122
 Legend:



Removed from v.1.33
 


changed lines


 
Added in v.1.122
-Removed from v.1.33
+Added in v.1.122

root@recompile.se	ViewVC Help
Powered by ViewVC 1.1.26