/[cvs]/stack/stack.c

Diff of /stack/stack.c

Parent Directory | Revision Log | View Patch Patch

-revision 1.25 by masse,
Sat Feb  2 20:06:11 2002 UTC
+revision 1.124 by teddy,
Sat Mar 30 02:31:24 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 */
+ #include <mcheck.h>
+ /* ioctl */
+ #include <sys/ioctl.h>
+ /* KDMKTONE */
+ #include <linux/kd.h>
+ #endif /* __linux__ */
+ #include "stack.h"
+ /* Initialize a newly created environment */
+ void init_env(environment *env)
+ {
+   int i;
+   env->gc_limit= 400000;
+   env->gc_count= 0;
+   env->gc_ref= NULL;
- typedef struct stack_item
+   env->head= new_val(env);
- {
+   for(i= 0; i<HASHTBLSIZE; i++)
-   enum {
+     env->symbols[i]= NULL;
-     value,                      /* Integer */
+   env->err= 0;
-     string,
+   env->in_string= NULL;
-     ref,                        /* Reference (to an element in the
+   env->free_string= NULL;
-                                    hash table) */
+   env->inputstream= stdin;
-     func,                       /* Function pointer */
+   env->interactive= 1;
-     symbol,
+ }
-     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 */
-   char* id;                     /* Symbol name */
-   struct stack_item* next;      /* Next element */
- } stackitem;
- typedef stackitem* hashtbl[HASHTBLSIZE]; /* Hash table declaration */
- typedef void (*funcp)(stackitem**); /* funcp is a pointer to a
-                                        void function (stackitem **) */
- /* Initialize a newly created hash table. */
+ void printerr(const char* in_string)
- void init_hashtbl(hashtbl out_hash)
  {
-   long i;
+   fprintf(stderr, "Err: %s\n", in_string);
+ }
-   for(i= 0; i<HASHTBLSIZE; i++)
+ /* Discard the top element of the stack. */
-     out_hash[i]= NULL;
+ 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 an element in the hash table. */
+ /* Returns a pointer to a pointer to an element in the hash table. */
- stackitem** hash(hashtbl in_hashtbl, const char* in_string)
+ 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';
-   stackitem** position;
+   symbol **position;
    while(1){                     /* Hash in_string */
      key= in_string[i++];
-Line 75 
 stackitem** hash(hashtbl in_hashtbl, con
+Line 117 
 stackitem** hash(hashtbl in_hashtbl, con
    }
  }
- /* Generic push function. */
+ /* Create new value */
- int push(stackitem** stack_head, stackitem* in_item)
+ value* new_val(environment *env)
  {
-   in_item->next= *stack_head;
+   value *nval= malloc(sizeof(value));
-   *stack_head= in_item;
+   stackitem *nitem= malloc(sizeof(stackitem));
-   return 1;
+   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;
  }
- /* Push a value on the stack. */
+ /* Mark values recursively.
- int push_val(stackitem** stack_head, int in_val)
+    Marked values are not collected by the GC. */
+ inline void gc_mark(value *val)
  {
-   stackitem* new_item= malloc(sizeof(stackitem));
+   if(val==NULL || val->gc.flag.mark)
-   assert(new_item != NULL);
+     return;
-   new_item->content.val= in_val;
-   new_item->type= value;
+   val->gc.flag.mark= 1;
-   push(stack_head, new_item);
+   if(val->type==tcons) {
-   return 1;
+     gc_mark(CAR(val));
+     gc_mark(CDR(val));
+   }
  }
- /* Copy a string onto the stack. */
+ inline void gc_maybe(environment *env)
- int push_cstring(stackitem** stack_head, const char* in_string)
  {
-   stackitem* new_item= malloc(sizeof(stackitem));
+   if(env->gc_count < env->gc_limit)
-   new_item->content.ptr= malloc(strlen(in_string)+1);
+     return;
-   strcpy(new_item->content.ptr, in_string);
+   else
-   new_item->type= string;
+     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 port:
+       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);
-   push(stack_head, new_item);
-   return 1;
  }
- /* Create a new hash entry. */
+ /* Protect values from GC */
- int mk_hashentry(hashtbl in_hashtbl, stackitem* in_item, const char* id)
+ void protect(value *val)
  {
-   in_item->id= malloc(strlen(id)+1);
+   if(val==NULL || val->gc.flag.protect)
+     return;
-   strcpy(in_item->id, id);
+   val->gc.flag.protect= 1;
-   push(hash(in_hashtbl, id), in_item);
-   return 1;
+   if(val->type==tcons) {
+     protect(CAR(val));
+     protect(CDR(val));
+   }
  }
- /* Define a new function in the hash table. */
+ /* Unprotect values from GC */
- void def_func(hashtbl in_hashtbl, funcp in_func, const char* id)
+ void unprotect(value *val)
  {
-   stackitem* temp= malloc(sizeof(stackitem));
+   if(val==NULL || !(val->gc.flag.protect))
+     return;
-   temp->type= func;
+   val->gc.flag.protect= 0;
-   temp->content.ptr= in_func;
-   mk_hashentry(in_hashtbl, temp, id);
+   if(val->type==tcons) {
+     unprotect(CAR(val));
+     unprotect(CDR(val));
+   }
  }
- /* Define a new symbol in the hash table. */
+ /* Push a value onto the stack */
- void def_sym(hashtbl in_hashtbl, const char* id)
+ void push_val(environment *env, value *val)
  {
-   stackitem* temp= malloc(sizeof(stackitem));
+   value *new_value= new_val(env);
-   temp->type= symbol;
+   new_value->content.c= malloc(sizeof(pair));
-   mk_hashentry(in_hashtbl, temp, id);
+   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 a reference to an entry in the hash table onto the stack. */
+ /* Push an integer onto the stack */
- int push_ref(stackitem** stack_head, hashtbl in_hash, const char* in_string)
+ void push_int(environment *env, int in_val)
  {
-   static void* handle= NULL;
+   value *new_value= new_val(env);
-   void* symbol;
+   new_value->content.i= in_val;
+   new_value->type= integer;
-   stackitem* new_item= malloc(sizeof(stackitem));
+   push_val(env, new_value);
-   new_item->content.ptr= *hash(in_hash, in_string);
+ }
-   new_item->type= ref;
-   if(new_item->content.ptr==NULL) { /* If hash entry empty */
+ /* Push a floating point number onto the stack */
-     if(handle==NULL)            /* If no handle */
+ void push_float(environment *env, float in_val)
-       handle= dlopen(NULL, RTLD_LAZY);
+ {
+   value *new_value= new_val(env);
-     symbol= dlsym(handle, in_string); /* Get function pointer */
+   new_value->content.f= in_val;
-     if(dlerror()==NULL)         /* If existing function pointer */
+   new_value->type= tfloat;
-       def_func(in_hash, symbol, in_string); /* Store function pointer */
-     else
-       def_sym(in_hash, in_string); /* Make symbol */
-     new_item->content.ptr= *hash(in_hash, in_string); /* The new reference
-                                                          shouldn't point at
-                                                          NULL */
-     new_item->type= ref;
-   }
-   push(stack_head, new_item);
+   push_val(env, new_value);
-   return 1;
  }
- void printerr(const char* in_string) {
+ /* Copy a string onto the stack. */
-   fprintf(stderr, "Err: %s\n", in_string);
+ void push_cstring(environment *env, const char *in_string)
+ {
+   value *new_value= new_val(env);
+   int length= 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;
+   push_val(env, new_value);
+ }
+ /* 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 */
  }
- /* Discard the top element of the stack. */
+ extern void mangle(environment *env)
- extern void toss(stackitem** stack_head)
  {
-   stackitem* temp= *stack_head;
+   char *new_string;
-   if((*stack_head)==NULL) {
+   if(env->head->type==empty) {
-     printerr("Stack empty");
+     printerr("Too Few Arguments");
+     env->err= 1;
      return;
    }
-   if((*stack_head)->type==string)
-     free((*stack_head)->content.ptr);
-   *stack_head= (*stack_head)->next;
+   if(CAR(env->head)->type!=string) {
-   free(temp);
+     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. */
+ void push_sym(environment *env, const char *in_string)
+ {
+   value *new_value;             /* A new symbol value */
+   /* ...which might point to... */
+   symbol **new_symbol;          /* (if needed) A new actual symbol */
+   /* ...which, if possible, will be bound to... */
+   value *new_fvalue;            /* (if needed) A new function value */
+   /* ...which will point to... */
+   void *funcptr;                /* A function pointer */
+   static void *handle= NULL;    /* Dynamic linker handle */
+   const char *dlerr;            /* Dynamic linker error */
+   char *mangled;                /* Mangled function name */
+   new_value= new_val(env);
+   protect(new_value);
+   new_fvalue= new_val(env);
+   protect(new_fvalue);
+   /* The new value is a symbol */
+   new_value->type= symb;
+   /* Look up the symbol name in the hash table */
+   new_symbol= hash(env->symbols, in_string);
+   new_value->content.ptr= *new_symbol;
+   if(*new_symbol==NULL) { /* If symbol was undefined */
+     /* 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 */
+     new_value->content.ptr= *new_symbol;
+     /* Try to load the symbol name as an external function, to see if
+        we should bind the symbol to a new function pointer value */
+     if(handle==NULL)            /* If no handle */
+       handle= dlopen(NULL, RTLD_LAZY);
+     mangled= mangle_str(in_string); /* mangle the name */
+     funcptr= dlsym(handle, mangled); /* and try to find it */
+     dlerr= dlerror();
+     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 */
+     }
+     free(mangled);
+   }
+   push_val(env, new_value);
+   unprotect(new_value); unprotect(new_fvalue);
  }
  /* Print newline. */
- extern void nl()
+ extern void nl(environment *env)
  {
    printf("\n");
  }
- /* Prints the top element of the stack. */
+ /* Print a newline to a port */
- extern void print_(stackitem** stack_head)
+ extern void nlport(environment *env)
  {
-   stackitem* temp= *stack_head;
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type!=port) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
-   if(temp==NULL) {
+   if(fprintf(CAR(env->head)->content.p, "\n") < 0){
-     printerr("Stack empty");
+     perror("nl");
+     env->err= 5;
      return;
    }
+   toss(env);
+ }
-   while(temp->type==ref)
+ /* Gets the type of a value */
-     temp= temp->content.ptr;
+ extern void type(environment *env)
+ {
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
-   switch(temp->type) {
+   switch(CAR(env->head)->type){
-   case value:
+   case empty:
-     printf("%d", temp->content.val);
+     push_sym(env, "empty");
+     break;
+   case integer:
+     push_sym(env, "integer");
+     break;
+   case tfloat:
+     push_sym(env, "float");
      break;
    case string:
-     printf("\"%s\"", (char*)temp->content.ptr);
+     push_sym(env, "string");
+     break;
+   case symb:
+     push_sym(env, "symbol");
      break;
-   case symbol:
    case func:
-     printf("%s", temp->id);
+     push_sym(env, "function");
      break;
-   default:
+   case tcons:
-     printf("%p", temp->content.ptr);
+     push_sym(env, "pair");
+     break;
+   case port:
+     push_sym(env, "port");
+     break;
+   }
+   swap(env);
+   if (env->err) return;
+   toss(env);
+ }
+ /* Print a value */
+ void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
+ {
+   stackitem *titem, *tstack;
+   int depth;
+   switch(val->type) {
+   case empty:
+     if(fprintf(stream, "[]") < 0){
+       perror("print_val");
+       env->err= 5;
+       return;
+     }
+     break;
+   case integer:
+     if(fprintf(stream, "%d", val->content.i) < 0){
+       perror("print_val");
+       env->err= 5;
+       return;
+     }
+     break;
+   case tfloat:
+     if(fprintf(stream, "%f", val->content.f) < 0){
+       perror("print_val");
+       env->err= 5;
+       return;
+     }
+     break;
+   case string:
+     if(noquote){
+       if(fprintf(stream, "%s", (char*)(val->content.ptr)) < 0){
+         perror("print_val");
+         env->err= 5;
+         return;
+       }
+     } else {                    /* quote */
+       if(fprintf(stream, "\"%s\"", (char*)(val->content.ptr)) < 0){
+         perror("print_val");
+         env->err= 5;
+         return;
+       }
+     }
+     break;
+   case symb:
+     if(fprintf(stream, "%s", val->content.sym->id) < 0){
+       perror("print_val");
+       env->err= 5;
+       return;
+     }
+     break;
+   case func:
+     if(fprintf(stream, "#<function %p>", (funcp)(val->content.ptr)) < 0){
+       perror("print_val");
+       env->err= 5;
+       return;
+     }
+     break;
+   case port:
+     if(fprintf(stream, "#<port %p>", (funcp)(val->content.p)) < 0){
+       perror("print_val");
+       env->err= 5;
+       return;
+     }
+     break;
+   case tcons:
+     if(fprintf(stream, "[ ") < 0){
+       perror("print_val");
+       env->err= 5;
+       return;
+     }
+     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, */
+         if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
+           perror("print_val");
+           env->err= 5;
+           free(titem);
+           return;
+         }
+       } else {
+         print_val(env, CAR(val), noquote, tstack, stream);
+       }
+       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, */
+           if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
+             perror("print_val");
+             env->err= 5;
+             goto printval_end;
+           }
+         } else {
+           if(fprintf(stream, " ") < 0){
+             perror("print_val");
+             env->err= 5;
+             goto printval_end;
+           }
+         }
+         break;
+       default:
+         if(fprintf(stream, " . ") < 0){ /* Improper list */
+           perror("print_val");
+           env->err= 5;
+           goto printval_end;
+         }
+         print_val(env, val, noquote, tstack, stream);
+       }
+     } while(val->type == tcons && titem == NULL);
+   printval_end:
+     titem=tstack;
+     while(titem != stack){
+       tstack=titem->next;
+       free(titem);
+       titem=tstack;
+     }
+     if(! (env->err)){
+       if(fprintf(stream, " ]") < 0){
+         perror("print_val");
+         env->err= 5;
+       }
+     }
      break;
    }
  }
- /* Prints the top element of the stack and then discards it. */
+ /* Print the top element of the stack but don't discard it */
- extern void print(stackitem** stack_head)
+ extern void print_(environment *env)
  {
-   print_(stack_head);
+   if(env->head->type==empty) {
-   toss(stack_head);
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   print_val(env, CAR(env->head), 0, NULL, stdout);
+   if(env->err) return;
+   nl(env);
  }
- /* Only to be called by function printstack. */
+ /* Prints the top element of the stack */
- void print_st(stackitem* stack_head, long counter)
+ extern void print(environment *env)
  {
-   if(stack_head->next != NULL)
+   print_(env);
-     print_st(stack_head->next, counter+1);
+   if(env->err) return;
+   toss(env);
+ }
+ /* Print the top element of the stack without quotes, but don't
+    discard it. */
+ extern void princ_(environment *env)
+ {
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   print_val(env, CAR(env->head), 1, NULL, stdout);
+ }
+ /* Prints the top element of the stack without quotes. */
+ extern void princ(environment *env)
+ {
+   princ_(env);
+   if(env->err) return;
+   toss(env);
+ }
+ /* Print a value to a port, but don't discard it */
+ extern void printport_(environment *env)
+ {
+   if(env->head->type==empty ||  CDR(env->head)->type == empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type!=port) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p);
+   if(env->err) return;
+   nlport(env);
+ }
+ /* Print a value to a port */
+ extern void printport(environment *env)
+ {
+   printport_(env);
+   if(env->err) return;
+   toss(env);
+ }
+ /* Print, without quotes, to a port, a value, but don't discard it. */
+ extern void princport_(environment *env)
+ {
+   if(env->head->type==empty ||  CDR(env->head)->type == empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type!=port) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p);
+   toss(env); if(env->err) return;
+ }
+ /* Print, without quotes, to a port, the top element. */
+ extern void princport(environment *env)
+ {
+   princport_(env);
+   if(env->err) return;
+   toss(env);
+ }
+ /* Only to be called by itself function printstack. */
+ void print_st(environment *env, value *stack_head, long counter)
+ {
+   if(CDR(stack_head)->type != empty)
+     print_st(env, CDR(stack_head), counter+1);
    printf("%ld: ", counter);
-   print_(&stack_head);
+   print_val(env, CAR(stack_head), 0, NULL, stdout);
-   nl();
+   nl(env);
  }
  /* Prints the stack. */
- extern void printstack(stackitem** stack_head)
+ extern void printstack(environment *env)
  {
-   if(*stack_head != NULL) {
+   if(env->head->type == empty) {
-     print_st(*stack_head, 1);
+     printf("Stack Empty\n");
-     nl();
+     return;
-   } else {
-     printerr("Stack empty");
    }
+   print_st(env, env->head, 1);
  }
- /* If the top element is a reference, determine if it's a reference to a
+ /* Swap the two top elements on the stack. */
-    function, and if it is, toss the reference and execute the function. */
+ extern void swap(environment *env)
- extern void eval(stackitem** stack_head)
  {
-   funcp in_func;
+   value *temp= env->head;
-   stackitem* temp= *stack_head;
+   if(env->head->type == empty || CDR(env->head)->type == empty) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   env->head= CDR(env->head);
+   CDR(temp)= CDR(env->head);
+   CDR(env->head)= temp;
+ }
+ /* Rotate the first three elements on the stack. */
+ extern void rot(environment *env)
+ {
+   value *temp= env->head;
+   if(env->head->type == empty || CDR(env->head)->type == empty
+      || CDR(CDR(env->head))->type == empty) {
+     printerr("Too Few Arguments");
+     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 */
+ extern void rcl(environment *env)
+ {
+   value *val;
-   if(temp==NULL) {
+   if(env->head->type==empty) {
-     printerr("Stack empty");
+     printerr("Too Few Arguments");
+     env->err= 1;
      return;
    }
-   while(temp->type==ref)
+   if(CAR(env->head)->type!=symb) {
-     temp= temp->content.ptr;
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
-   if(temp->type==func) {
+   val= CAR(env->head)->content.sym->val;
-     in_func= (funcp)(temp->content.ptr);
+   if(val == NULL){
-     toss(stack_head);
+     printerr("Unbound Variable");
-     (*in_func)(stack_head);
+     env->err= 3;
      return;
    }
+   push_val(env, val);           /* Return the symbol's 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
+    function value, and if it is, toss the symbol and execute the
+    function. */
+ extern void eval(environment *env)
+ {
+   funcp in_func;
+   value* temp_val;
+   value* iterator;
+  eval_start:
+   gc_maybe(env);
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   switch(CAR(env->head)->type) {
+     /* if it's a symbol */
+   case symb:
+     rcl(env);                   /* get its contents */
+     if(env->err) return;
+     if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
+       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;
-   printerr("Couldn't evaluate");
+     while(iterator->type != empty) {
+       push_val(env, CAR(iterator));
+       if(CAR(env->head)->type==symb
+          && CAR(env->head)->content.sym->id[0]==';') {
+         toss(env);
+         if(env->err) return;
+         if(CDR(iterator)->type == empty){
+           goto eval_start;
+         }
+         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:
+     toss(env);
+   case integer:
+   case tfloat:
+   case string:
+   case port:
+     return;
+   }
  }
- /* Make a list. */
+ /* Reverse (flip) a list */
- extern void pack(stackitem** stack_head)
+ extern void rev(environment *env)
  {
-   void* delimiter;
+   value *old_head, *new_head, *item;
-   stackitem *iterator, *temp, *pack;
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
-   delimiter= (*stack_head)->content.ptr; /* Get delimiter */
+   if(CAR(env->head)->type==empty)
-   toss(stack_head);
+     return;                     /* Don't reverse an empty list */
-   iterator= *stack_head;
+   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)
+ {
+   value *iterator, *temp, *ending;
+   ending=new_val(env);
-   if(iterator==NULL || iterator->content.ptr==delimiter) {
+   iterator= env->head;
-     temp= NULL;
+   if(iterator->type == empty
-     toss(stack_head);
+      || (CAR(iterator)->type==symb
+      && CAR(iterator)->content.sym->id[0]=='[')) {
+     temp= ending;
+     toss(env);
    } else {
      /* Search for first delimiter */
-     while(iterator->next!=NULL && iterator->next->content.ptr!=delimiter)
+     while(CDR(iterator)->type != empty
-       iterator= iterator->next;
+           && (CAR(CDR(iterator))->type!=symb
+            || CAR(CDR(iterator))->content.sym->id[0]!='['))
+       iterator= CDR(iterator);
      /* Extract list */
-     temp= *stack_head;
+     temp= env->head;
-     *stack_head= iterator->next;
+     env->head= CDR(iterator);
-     iterator->next= NULL;
+     CDR(iterator)= ending;
-     if(*stack_head!=NULL && (*stack_head)->content.ptr==delimiter)
+     if(env->head->type != empty)
-       toss(stack_head);
+       toss(env);
    }
    /* Push list */
-   pack= malloc(sizeof(stackitem));
-   pack->type= list;
-   pack->content.ptr= temp;
-   push(stack_head, pack);
+   push_val(env, temp);
+   rev(env);
  }
- /* Parse input. */
+ /* Relocate elements of the list on the stack. */
- int stack_read(stackitem** stack_head, hashtbl in_hash, char* in_line)
+ extern void expand(environment *env)
  {
-   char *temp, *rest;
+   value *temp, *new_head;
-   int itemp;
-   size_t inlength= strlen(in_line)+1;
-   int convert= 0;
-   static int non_eval_flag= 0;
-   temp= malloc(inlength);
+   /* Is top element a list? */
-   rest= malloc(inlength);
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
-   do {
+   if(CAR(env->head)->type!=tcons) {
-     /* If string */
+     printerr("Bad Argument Type");
-     if((convert= sscanf(in_line, "\"%[^\"\n\r]\" %[^\n\r]", temp, rest))) {
+     env->err= 2;
-       push_cstring(stack_head, temp);
+     return;
-       break;
+   }
+   rev(env);
+   if(env->err)
+     return;
+   /* The first list element is the new stack head */
+   new_head= temp= CAR(env->head);
+   toss(env);
+   /* Find the end of the list */
+   while(CDR(temp)->type != empty) {
+     if (CDR(temp)->type == tcons)
+       temp= CDR(temp);
+     else {
+       printerr("Bad Argument Type"); /* Improper list */
+       env->err= 2;
+       return;
      }
-     /* If value */
+   }
-     if((convert= sscanf(in_line, "%d %[^\n\r]", &itemp, rest))) {
-       push_val(stack_head, itemp);
+   /* Connect the tail of the list with the old stack head */
-       break;
+   CDR(temp)= env->head;
+   env->head= new_head;          /* ...and voila! */
+ }
+ /* Compares two elements by reference. */
+ extern void eq(environment *env)
+ {
+   void *left, *right;
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   left= CAR(env->head)->content.ptr;
+   right= CAR(CDR(env->head))->content.ptr;
+   toss(env); toss(env);
+   push_int(env, left==right);
+ }
+ /* Negates the top element on the stack. */
+ extern void not(environment *env)
+ {
+   int val;
+   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;
+   }
+   val= CAR(env->head)->content.i;
+   toss(env);
+   push_int(env, !val);
+ }
+ /* Compares the two top elements on the stack and return 0 if they're the
+    same. */
+ extern void neq(environment *env)
+ {
+   eq(env);
+   not(env);
+ }
+ /* Give a symbol some content. */
+ extern void def(environment *env)
+ {
+   symbol *sym;
+   /* Needs two values on the stack, the top one must be a symbol */
+   if(env->head->type==empty || CDR(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;
+   }
+   /* long names are a pain */
+   sym= CAR(env->head)->content.ptr;
+   /* Bind the symbol to the value */
+   sym->val= CAR(CDR(env->head));
+   toss(env); toss(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]));
      }
-     /* Escape ';' with '\' */
+     env->symbols[i]= NULL;
-     if((convert= sscanf(in_line, "\\%c%[^\n\r]", temp, rest))) {
+   }
-       temp[1]= '\0';
-       push_ref(stack_head, in_hash, temp);
+   env->gc_limit= 0;
-       break;
+   gc_maybe(env);
-     }
-     /* If symbol */
+   words(env);
-     if((convert= sscanf(in_line, "%[^][ ;\n\r]%[^\n\r]", temp, rest))) {
-         push_ref(stack_head, in_hash, temp);
+   if(env->free_string!=NULL)
-         break;
+     free(env->free_string);
+ #ifdef __linux__
+   muntrace();
+ #endif
+   exit(EXIT_SUCCESS);
+ }
+ /* Clear stack */
+ extern void clear(environment *env)
+ {
+   while(env->head->type != empty)
+     toss(env);
+ }
+ /* List all defined words */
+ extern void words(environment *env)
+ {
+   symbol *temp;
+   int i;
+   for(i= 0; i<HASHTBLSIZE; i++) {
+     temp= env->symbols[i];
+     while(temp!=NULL) {
+ #ifdef DEBUG
+       if (temp->val != NULL && temp->val->gc.flag.protect)
+         printf("(protected) ");
+ #endif /* DEBUG */
+       printf("%s\n", temp->id);
+       temp= temp->next;
      }
-     /* If single char */
+   }
-     if((convert= sscanf(in_line, "%c%[^\n\r]", temp, rest))) {
+ }
-       if(*temp==';') {
-         if(!non_eval_flag) {
+ /* Internal forget function */
-           eval(stack_head);             /* Evaluate top element */
+ void forget_sym(symbol **hash_entry)
-           break;
+ {
-         }
+   symbol *temp;
-         push_ref(stack_head, in_hash, ";");
+   temp= *hash_entry;
-         break;
+   *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;
+   int c;                        /* getopt option character */
+ #ifdef __linux__
+   mtrace();
+ #endif
+   init_env(&myenv);
-       if(*temp==']') {
+   myenv.interactive = isatty(STDIN_FILENO) && isatty(STDOUT_FILENO);
-         push_ref(stack_head, in_hash, "[");
-         pack(stack_head);
+   while ((c = getopt (argc, argv, "i")) != -1)
-         if(non_eval_flag!=0)
+     switch (c)
-           non_eval_flag--;
+       {
+       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);
+     }
+   }
-       if(*temp=='[') {
+   if(myenv.interactive) {
-         push_ref(stack_head, in_hash, "[");
+     printf("Stack version $Revision$\n\
-         non_eval_flag++;
+ Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
-         break;
+ 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");
+   }
+   while(1) {
+     if(myenv.in_string==NULL) {
+       if (myenv.interactive) {
+         if(myenv.err) {
+           printf("(error %d)\n", myenv.err);
+           myenv.err= 0;
+         }
+         nl(&myenv);
+         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);
      }
-   } while(0);
+     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;
+   }
-   free(temp);
+   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(convert<2) {
+   if(CAR(env->head)->type==integer
-     free(rest);
+      && CAR(CDR(env->head))->type==tfloat) {
-     return 0;
+     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;
    }
-   stack_read(stack_head, in_hash, rest);
-   free(rest);
+   if(CAR(env->head)->type==integer
-   return 1;
+      && 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;
  }
- /* Relocate elements of the list on the stack. */
+ /* ">" */
- extern void expand(stackitem** stack_head)
+ extern void sx_3e(environment *env)
  {
-   stackitem *temp, *new_head;
+   int a, b;
+   float fa, fb;
-   /* Is top element a list? */
+   if(env->head->type==empty || CDR(env->head)->type==empty) {
-   if((*stack_head)==NULL || (*stack_head)->type!=list) {
+     printerr("Too Few Arguments");
-     printerr("Stack empty or not a list");
+     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);
-   /* The first list element is the new stack head */
+     return;
-   new_head= temp= (*stack_head)->content.ptr;
+   }
-   toss(stack_head);
-   if(temp==NULL)
+   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;
+   }
-   /* Search the end of the list */
+   if(CAR(env->head)->type==integer
-   while(temp->next!=NULL)
+      && CAR(CDR(env->head))->type==tfloat) {
-     temp= temp->next;
+     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);
-   /* Connect the the tail of the list with the old stack head */
+     return;
-   temp->next= *stack_head;
+   }
-   *stack_head= new_head;        /* ...and voila! */
+   printerr("Bad Argument Type");
+   env->err= 2;
  }
- /* Swap the two top elements on the stack. */
+ /* "<" */
- extern void swap(stackitem** stack_head)
+ 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;
+   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:
+   case port:
+     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;
+   }
+   return new_value;
+ }
+ /* "dup"; duplicates an item on the stack */
+ extern void sx_647570(environment *env)
  {
-   stackitem* temp= (*stack_head);
+   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;
-   if((*stack_head)==NULL) {
+   truth= CAR(env->head)->content.i;
-     printerr("Stack empty");
+   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((*stack_head)->next==NULL)
+   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;
-   *stack_head= (*stack_head)->next;
+   toss(env);
-   temp->next= (*stack_head)->next;
+   if(env->err) return;
-   (*stack_head)->next= temp;
- }
- /* Compares two elements by reference. */
+   if(!truth)
- extern void eq(stackitem** stack_head)
+     swap(env);
+   if(env->err) return;
+   toss(env);
+   if(env->err) return;
+   eval(env);
+ }
+ /* "else" */
+ extern void sx_656c7365(environment *env)
  {
-   void *left, *right;
+   if(env->head->type==empty || CDR(env->head)->type==empty
-   int result;
+      || 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((*stack_head)==NULL || (*stack_head)->next==NULL) {
+   if(CAR(CDR(env->head))->type!=symb
-     printerr("Not enough elements to compare");
+      || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
+     printerr("Bad Argument Type");
+     env->err= 2;
      return;
    }
-   left= (*stack_head)->content.ptr;
+   swap(env); toss(env);
-   swap(stack_head);
+   sx_6966(env);
-   right= (*stack_head)->content.ptr;
+ }
-   result= (left==right);
+ /* "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);
+     }
-   toss(stack_head); toss(stack_head);
+   } while(truth);
-   push_val(stack_head, (left==right));
+   unprotect(loop); unprotect(test);
  }
- /* Negates the top element on the stack. */
- extern void not(stackitem** stack_head)
+ /* "for"; for-loop */
+ extern void sx_666f72(environment *env)
  {
-   int value;
+   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((*stack_head)==NULL || (*stack_head)->type!=value) {
+   if(CAR(CDR(env->head))->type!=integer
-     printerr("Stack empty or element is not a value");
+      || CAR(CDR(CDR(env->head)))->type!=integer) {
+     printerr("Bad Argument Type");
+     env->err= 2;
      return;
    }
-   value= (*stack_head)->content.val;
+   loop= CAR(env->head);
-   toss(stack_head);
+   protect(loop);
-   push_val(stack_head, !value);
+   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);
  }
- /* Compares the two top elements on the stack and return 0 if they're the
+ /* Variant of for-loop */
-    same. */
+ extern void foreach(environment *env)
- extern void neq(stackitem** stack_head)
+ {
+   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)
  {
-   eq(stack_head);
+   readlinestream(env, env->inputstream);
-   not(stack_head);
  }
- /* Give a symbol some content. */
+ /* Read a string from a port */
- extern void def(stackitem** stack_head)
+ extern void readlineport(environment *env)
  {
-   stackitem *temp, *value;
+   FILE *stream;
-   if(*stack_head==NULL || (*stack_head)->next==NULL
+   if(env->head->type==empty) {
-      || (*stack_head)->type!=ref) {
+     printerr("Too Few Arguments");
-     printerr("Define what?");
+     env->err= 1;
      return;
    }
-   temp= (*stack_head)->content.ptr;
+   if(CAR(env->head)->type!=port) {
-   value= (*stack_head)->next;
+     printerr("Bad Argument Type");
-   temp->content= value->content;
+     env->err= 2;
-   value->content.ptr=NULL;
+     return;
-   temp->type= value->type;
+   }
-   toss(stack_head); toss(stack_head);
+   stream=CAR(env->head)->content.p;
- }
+   readlinestream(env, stream); if(env->err) return;
- /* Quit stack. */
+   swap(env); if(env->err) return;
- extern void quit()
+   toss(env);
+ }
+ /* read a line from a stream; used by readline */
+ void readlinestream(environment *env, FILE *stream)
  {
-   exit(EXIT_SUCCESS);
+   char in_string[101];
+   if(fgets(in_string, 100, stream)==NULL) {
+     push_cstring(env, "");
+     if (! feof(stream)){
+       perror("readline");
+       env->err= 5;
+     }
+   } else {
+     push_cstring(env, in_string);
+   }
  }
- /* Clear stack */
+ /* "read"; Read a value and place on stack */
- extern void clear(stackitem** stack_head)
+ extern void sx_72656164(environment *env)
  {
-   while(*stack_head!=NULL)
+   readstream(env, env->inputstream);
-     toss(stack_head);
  }
- int main()
+ /* "readport"; Read a value from a port and place on stack */
+ extern void readport(environment *env)
  {
-   stackitem* s= NULL;
+   FILE *stream;
-   hashtbl myhash;
-   char in_string[100];
-   init_hashtbl(myhash);
+   if(env->head->type==empty) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(CAR(env->head)->type!=port) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   stream=CAR(env->head)->content.p;
+   readstream(env, stream); if(env->err) return;
-   printf("okidok\n ");
+   swap(env); if(env->err) return;
+   toss(env);
+ }
+ /* read from a stream; used by "read" and "readport" */
+ void readstream(environment *env, FILE *stream)
+ {
+   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;
-   while(fgets(in_string, 100, stdin) != NULL) {
+     if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
-     stack_read(&s, myhash, in_string);
+       env->err= 4;              /* "" means EOF */
-     printf("okidok\n ");
+       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;
    }
-   exit(EXIT_SUCCESS);
+   free(match);
+   if(depth)
+     return sx_72656164(env);
  }
- /* Local Variables: */
+ #ifdef __linux__
- /* compile-command:"make CFLAGS=\"-Wall -g -rdynamic -ldl\" stack" */
+ extern void beep(environment *env)
- /* End: */
+ {
+   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);
+ }
+ /* "do" */
+ extern void sx_646f(environment *env)
+ {
+   swap(env); if(env->err) return;
+   eval(env);
+ }
+ /* "open" */
+ /* 2: "file"                                    */
+ /* 1: "r"       =>      1: #<port 0x47114711>   */
+ extern void sx_6f70656e(environment *env)
+ {
+   value *new_port;
+   FILE *stream;
+   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) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   stream=fopen(CAR(CDR(env->head))->content.ptr,
+                CAR(env->head)->content.ptr);
+   if(stream == NULL) {
+     perror("open");
+     env->err= 5;
+     return;
+   }
+   new_port=new_val(env);
+   new_port->type=port;
+   new_port->content.p=stream;
+   push_val(env, new_port);
+   swap(env); if(env->err) return;
+   toss(env); if(env->err) return;
+   swap(env); if(env->err) return;
+   toss(env);
+ }
+ /* "close" */
+ extern void sx_636c6f7365(environment *env)
+ {
+   int ret;
+   if(env->head->type == empty) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   if(CAR(env->head)->type != port) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   ret= fclose(CAR(env->head)->content.p);
+   if(ret != 0){
+     perror("close");
+     env->err= 5;
+     return;
+   }
+   toss(env);
+ }

 Legend:



Removed from v.1.25
 


changed lines


 
Added in v.1.124
 Legend:



Removed from v.1.25
 


changed lines


 
Added in v.1.124
-Removed from v.1.25
+Added in v.1.124

root@recompile.se	ViewVC Help
Powered by ViewVC 1.1.26