/*
 * Copyright (c) 2001-2026 James Bailie.
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 *     * Redistributions of source code must retain the above copyright
 * notice, this list of conditions and the following disclaimer.
 *     * Redistributions in binary form must reproduce the above copyright
 * notice, this list of conditions and the following disclaimer in the
 * documentation and/or other materials provided with the distribution.
 *     * The name of James Bailie may not be used to endorse or promote
 * products derived from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 */

#include "lisp.h"
#include "intrinsics.c"

void sigchld_handler( int signo )
{
   pid_t pid;

   if ( zombies )
      return;

   while(( pid = waitpid( -1, NULL, WNOHANG )) > 0 )
      if ( pid == child_pid )
         child_pid = -1;
}

void sigterm_handler( int signo )
{
   sigterm = 1;
}

void sigalrm_handler( int signo )
{
   sigalrm = 1;
}

void print_err( int err, char *func, int arg, int type )
{
   static char *types[] = { "", "symbol", "string", "fixnum",
                            "compiled regular expression",
                            "table", "stack", "intrinsic function",
                            "database connection", "closure", "macro",
                            "activation record",
                            "record", "compiled SQL statement", "list",
                            "atom" };
   char *ptr;

   if ( type > 0 && type < 16 && type != 11 )
      ptr = types[ type ];
   else
      ptr = "acceptable type";

   fprintf( stderr, error_messages[ err ], func, arg, ptr );
}

void *memory( unsigned long int size )
{
   void *ptr;

   if ( size == 0 )
      return NULL;

   if (( ptr = calloc( 1, size )) == NULL )
   {
      fprintf( stderr, "memory: calloc: %s.\n", strerror( errno ));
      exit( 1 );
   }

   return ptr;
}

char *str_dup( char *str, unsigned long int len )
{
   char *ptr;

   ptr = ( char *)memory( len + 1 );
   bcopy( str, ptr, len );
   ptr[ len ] = '\0';

   return ptr;
}

struct object *make_object()
{
   ++objects_allocated;

   if ( reclaimed_objects->used )
      return STACK_POP( reclaimed_objects );

   if ( object_pool_free == 0 )
   {
      STACK_PUSH( object_pool_stack, ( void *)object_pool )

      object_pool = ( struct object *)memory( sizeof( struct object ) * POOL_INC );
      object_pool_ptr = object_pool;
      object_pool_free = POOL_INC;

      bzero( object_pool, POOL_INC * sizeof( struct object ));
   }

   --object_pool_free;

   return object_pool_ptr++;
}

struct atom *make_atom()
{
   ++atoms_allocated;

   if ( reclaimed_atoms->used )
      return ( struct atom *)STACK_POP( reclaimed_atoms );

   if ( atom_pool_free == 0 )
   {
      STACK_PUSH( atom_pool_stack, ( void *)atom_pool )

      atom_pool = ( struct atom *)memory( sizeof( struct atom ) * POOL_INC );
      atom_pool_ptr = atom_pool;
      atom_pool_free = POOL_INC;

      bzero( atom_pool, POOL_INC * sizeof( struct atom ));
   }

   --atom_pool_free;

   return atom_pool_ptr++;
}

struct hash_elt *make_hash_elt()
{
   if ( reclaimed_hash_elts->used )
      return ( struct hash_elt *)STACK_POP( reclaimed_hash_elts );

   if ( hash_elt_pool_free == 0 )
   {
      STACK_PUSH( hash_elt_pool_stack, ( void *)hash_elt_pool )

      hash_elt_pool = ( struct hash_elt *)memory( sizeof( struct hash_elt ) * POOL_INC );
      hash_elt_pool_ptr = hash_elt_pool;
      hash_elt_pool_free = POOL_INC;

      bzero( hash_elt_pool, POOL_INC * sizeof( struct hash_elt ));
   }

   --hash_elt_pool_free;

   return hash_elt_pool_ptr++;
}

unsigned long int hash_key( char *name, unsigned long int len )
{
   unsigned long int i, key;
   char *nptr;

   if ( len > LONG_MAX )
   {
      fprintf( stderr, "objects cannot have print syntax longer than "
                       "(maxidx): %lu.\n", LONG_MAX );
      exit( 1 );
   }

   key = 2166136261;

   for( i = 0, nptr = name; i < len; ++nptr, ++i )
      key = ( key * 16777619 ) ^ *nptr;

   return key;
}

int insert_elt( struct hash_elt **hash, struct atom *atom, struct object *object, unsigned long int size )
{
   unsigned long int orig, key;
   struct hash_elt *ptr = NULL, *ptr2 = NULL;
   int found = 0;

   orig = hash_key( atom->syntax, atom->len );
   key = orig % size;

   if ( hash[ key ] == NULL )
   {
      hash[ key ] = make_hash_elt();
      hash[ key ]->element.ptr = object;
      hash[ key ]->next = NULL;
      hash[ key ]->key = atom;
      hash[ key ]->hash_key = orig;
      return found;
   }

   ptr2 = hash[ key ];

   for( ptr = ptr2; ptr != NULL; ptr = ptr->next )
      if ( ptr->key->id == atom->id )
      {
         ++found;
         break;
      }
      else
         ptr2 = ptr;

   if ( ptr == NULL )
   {
      ptr2->next = make_hash_elt();
      ptr = ptr2->next;
      ptr->next = NULL;
      ptr->hash_key = orig;
   }

   ptr->element.ptr = object;
   ptr->key = atom;

   return found;
}

void insert_elt_int( struct hash_elt **hash, struct atom *atom, long int elt )
{
   unsigned long int orig, key;
   struct hash_elt *ptr = NULL, *ptr2 = NULL;

   orig = hash_key( atom->syntax, atom->len );
   key = orig % HASH_SIZE;

   if ( hash[ key ] == NULL )
   {
      hash[ key ] = make_hash_elt();
      hash[ key ]->element.integer = elt;
      hash[ key ]->next = NULL;
      hash[ key ]->key = atom;
      hash[ key ]->hash_key = orig;
      return;
   }

   ptr2 = hash[ key ];

   for( ptr = ptr2; ptr != NULL; ptr = ptr->next )
      if ( ptr->key->id == atom->id )
         break;
      else
         ptr2 = ptr;

   if ( ptr == NULL )
   {
      ptr2->next = make_hash_elt();
      ptr = ptr2->next;
      ptr->next = NULL;
      ptr->hash_key = orig;
   }

   ptr->element.integer = elt;
   ptr->key = atom;
}

void *lookup_elt( struct hash_elt **hash, struct atom *atom, unsigned long int size )
{
   unsigned long int key;
   struct hash_elt *ptr;

   key = hash_key( atom->syntax, atom->len );
   key %= size;

   if ( hash[ key ] == NULL )
      return NULL;

   ptr = hash[ key ];

   do
   {
      if ( ptr->key->id == atom->id )
         return ptr->element.ptr;

      ptr = ptr->next;
   }
   while( ptr != NULL );

   return NULL;
}

int lookup_elt_int( struct hash_elt **hash, struct atom *atom )
{
   unsigned long int key;
   struct hash_elt *ptr;

   key = hash_key( atom->syntax, atom->len );
   key %= HASH_SIZE;

   if ( hash[ key ] == NULL )
      return 0;

   ptr = hash[ key ];

   do
   {
      if ( ptr->key->id == atom->id )
         return ptr->element.integer;

      ptr = ptr->next;
   }
   while( ptr != NULL );

   return 0;
}

int remove_elt( struct hash_elt **hash, struct atom *atom, unsigned long int size )
{
   unsigned long int key;
   struct hash_elt *ptr, *ptr2;

   key = hash_key( atom->syntax, atom->len );
   key %= size;

   if ( hash[ key ] == NULL )
      return 0;

   ptr = hash[ key ];
   ptr2 = NULL;

   do
   {
      if ( ptr->key->id == atom->id )
         break;

      ptr2 = ptr;
      ptr = ptr->next;
   }
   while( ptr != NULL );

   if ( ptr == NULL )
      return 0;

   if ( ptr2 == NULL )
      hash[ key ] = ptr->next;
   else
      ptr2->next = ptr->next;

   bzero( ptr, sizeof( struct hash_elt ));
   STACK_PUSH( reclaimed_hash_elts, ptr )

   return 1;
}

void remove_id( char *name, unsigned long int len, int id )
{
   unsigned long int key;
   struct hash_elt *ptr, *ptr2;

   key = hash_key( name, len );
   key %= syntax_size;

   if ( syntax[ key ] == NULL )
      return;

   ptr = syntax[ key ];
   ptr2 = NULL;

   do
   {
      if ( ptr->key->id == id )
         break;

      ptr2 = ptr;
      ptr = ptr->next;
   }
   while( ptr != NULL );

   if ( ptr == NULL )
      return;

   --syntax_items;

   if ( ptr2 == NULL )
      syntax[ key ] = ptr->next;
   else
      ptr2->next = ptr->next;

   free_atom(( struct atom *)ptr->element.ptr );

   bzero( ptr, sizeof( struct hash_elt ));
   STACK_PUSH( reclaimed_hash_elts, ptr )
}

void resize_syntax()
{
   struct hash_elt **new, **old, **ptr, *ptr2, *ptr3, *nptr, *nptr2;
   unsigned long size, i, old_size;
   unsigned long int idx;

   if ( syntax_size * HASH_RESIZE > ULONG_MAX )
      return;

   size = syntax_size * HASH_RESIZE;

#ifdef DEBUG
   fprintf( stderr, "[resizing syntax table: items: %lu, old size: %lu...", syntax_items, syntax_size );
#endif

   new = memory( size * sizeof( struct hash_elt * ));
   old = syntax;
   old_size = syntax_size;

   syntax = new;
   syntax_size = size;
   syntax_resize = size * HASH_RESIZE;

   for( ptr = old, i = 0; i < old_size; ++i, ++ptr )
   {
      if ( *ptr == NULL )
         continue;

      for( ptr2 = *ptr; ptr2 != NULL; ptr2 = ptr3 )
      {
         ptr3 = ptr2->next;

         idx = ptr2->hash_key;
         idx %= size;

         if ( syntax[ idx ] == NULL )
         {
            syntax[ idx ] = ptr2;
            syntax[ idx ]->next = NULL;
         }
         else
         {
            for( nptr2 = nptr = syntax[ idx ]; nptr != NULL; nptr = nptr->next )
               nptr2 = nptr;

            nptr2->next = ptr2;
            nptr2 = nptr2->next;
            nptr2->next= NULL;
         }
      }
   }

   free( old );

#ifdef DEBUG
   fprintf( stderr, "new size: %lu]\n", syntax_size );
#endif
}

struct atom *get_id( char *name, unsigned long int len, int duplicate )
{
   unsigned int orig, key;
   struct atom *atom;
   struct hash_elt *ptr = NULL, *ptr2 = NULL;

   if ( syntax_items > syntax_resize )
      resize_syntax();

   orig = hash_key( name, len );
   key = orig % syntax_size;

   if ( syntax[ key ] == NULL )
   {
      atom = make_atom();
      atom->syntax = ( duplicate ? str_dup( name, len ) : name );
      atom->len = len;

      if ( reclaimed_ids->used )
         atom->id = STACK_POP_INT( reclaimed_ids );
      else if ( atom_counter == 0 )
      {
         fprintf( stderr, "get_id(): unique atomic ids exhausted.\n" );
         exit( 1 );
      }
      else
         atom->id = atom_counter++;

      syntax[ key ] = make_hash_elt();
      syntax[ key ]->element.ptr = ( struct object *)atom;
      syntax[ key ]->next = NULL;
      syntax[ key ]->key = atom;
      syntax[ key ]->hash_key = orig;
      ++syntax_items;

      return atom;
   }

   ptr2 = syntax[ key ];

   for( ptr = ptr2; ptr != NULL; ptr = ptr->next )
   {
      char *ptr3, *ptr4;
      unsigned int len1, len2;

      atom = ( struct atom *)ptr->element.ptr;

      for( ptr3 = name, ptr4 = atom->syntax, len1 = len, len2 = atom->len;
           len1 && len2;
           ++ptr3, ++ptr4, --len1, --len2 )

         if ( *ptr3 != *ptr4 )
            break;

      if ( ! len1 && ! len2 )
         return atom;

      ptr2 = ptr;
   }

   ptr2->next = make_hash_elt();
   ptr = ptr2->next;
   ptr->next = NULL;
   ptr->hash_key = orig;
   ++syntax_items;

   atom = make_atom();
   atom->syntax = ( duplicate ? str_dup( name, len ) : name );
   atom->len = len;

   if ( reclaimed_ids->used )
      atom->id = STACK_POP_INT( reclaimed_ids );
   else if ( atom_counter == 0 )
   {
      fprintf( stderr, "get_id(): unique atomic ids exhausted.\n" );
      exit( 1 );
   }
   else
      atom->id = atom_counter++;

   ptr->element.ptr = ( struct object *)atom;
   ptr->key = atom;

   return atom;
}

void hash_free( struct hash_elt **hash, unsigned long int size )
{
   int i;
   struct hash_elt **ptr, *ptr2, *ptr3;

   ptr = hash;

   for( i = 0; i < size; ++i )
   {
      if ( *ptr == NULL )
      {
         ++ptr;
         continue;
      }

      ptr2 = *ptr;

      do
      {
         ptr3 = ptr2->next;
         bzero( ptr2, sizeof( struct hash_elt ));
         STACK_PUSH( reclaimed_hash_elts, ptr2 )
         ptr2 = ptr3;
      }
      while( ptr2 != NULL );

      ++ptr;
   }
}

void free_syntax()
{
   struct atom *top;
   int i, j;

   i = atom_pool_stack->used;

   while( i )
   {
      top = ( struct atom *)atom_pool_stack->values[ --i ].ptr;

      for( j = 0; j < POOL_INC; ++j, ++top )
         free_atom( top );
   }

   for( top = atom_pool; top < atom_pool_ptr; ++top )
      free_atom( top );
}

struct stack *make_stack()
{
   struct stack *a;

   a = ( struct stack *)memory( sizeof( struct stack ));
   a->values = memory( sizeof( union stack_u ) * stack_inc );
   a->free = stack_inc;
   a->used = 0;
   a->top = a->values;

   return a;
}

void string_free( struct string *s )
{
   free( s->str );
   free( s );
}

struct string *make_string()
{
   struct string *s;

   s = ( struct string *)memory( sizeof( struct string ));
   s->str = ( char *)memory( string_inc + 1 );
   *s->str = '\0';
   s->free = string_inc;
   s->used = 0;
   s->top = s->str;

   return s;
}

int load( char *filename )
{
   struct object *result = NULL;
   int count;
   int file;

   file = open( filename, O_RDONLY | O_NONBLOCK | O_SHLOCK );

   if ( file == -1 )
   {
      fprintf( stderr, "load: %s: %s\n", filename, strerror( errno ));
      return 1;
   }

   for( count = 1; ; ++count )
   {
      int depth;

      depth = parse( file );

      if ( depth > 0 )
         break;
      else if ( depth < 0 )
         fprintf( stderr, "%d extra ')'\n", -depth );

      if ( evaluate() )
      {
         close( file );
         get_token( 0, -1 );

         if ( !stop )
            fprintf( stderr, "load: evaluation of expression %d in %s failed.\n", count, filename );
         else if ( thrown != NULL )
            fputs( "load: uncaught \"throw\"\n", stderr );
         else if ( next_iteration )
            fputs( "load: \"continue\" used outside of loop\n", stderr );

         if ( fatal )
            exit( 1 );

         thrown = NULL;
         stop = next_iteration = 0;
         return 1;
      }

      result = STACK_POP( stack );
   }

   close( file );

   if ( input_stack->used )
   {
      fprintf( stderr, "load: expression %d is unterminated in %s\n", count, filename );
      get_token( 0, -1 );
      return 1;
   }

   STACK_PUSH( stack, result )

   return 0;
}

void init_intrinsics()
{
   int ( **fp )( char *, struct object *);
   char **sp;
   struct atom *entry1, *entry2;
   struct object *object;

   sp = intrinsic_syntax;

   for( fp = intrinsics; *fp != NULL; ++fp )
   {
      entry1 = get_id( *sp, strlen( *sp ), 1 );
      entry1->flags = ATOM_INTRINSIC;
      entry1->data.function = *fp;

      object = make_object();
      mark( object->flags );
      object->data.atom = entry1;

      ++sp;

      entry2= get_id( *sp, strlen( *sp ), 1 );
      entry2->flags = ATOM_SYMBOL;

      insert_binding( entry2, object );

      ++sp;
   }
}

void set_sigwinch_intr()
{
   struct sigaction sigact;

   sigact.sa_handler = sigwinch_handler;
   sigemptyset( &sigact.sa_mask );
   sigact.sa_flags = 0;

   if ( sigaction( SIGWINCH, &sigact, NULL ) < 0 )
      fprintf( stderr, "initialize: sigaction: %s.\n", strerror( errno ));
}

void set_sigterm_intr()
{
   struct sigaction sigact;

   sigact.sa_handler = sigterm_handler;
   sigemptyset( &sigact.sa_mask );
   sigact.sa_flags = 0;

   if ( sigaction( SIGTERM, &sigact, NULL ) < 0 )
      fprintf( stderr, "initialize: sigaction: %s.\n", strerror( errno ));
}

void set_sigalrm_intr()
{
   struct sigaction sigact;

   sigact.sa_handler = sigalrm_handler;
   sigemptyset( &sigact.sa_mask );
   sigact.sa_flags = 0;

   if ( sigaction( SIGALRM, &sigact, NULL ) < 0 )
      fprintf( stderr, "initialize: sigaction: %s.\n", strerror( errno ));
}

void initialize( int argc, char **argv )
{
   int i, result;
   struct hash_elt **ptr;
   struct atom *atom;
   struct string *s;
   char err[ 80 ], *ptr2;
   struct stat stats;

   serv_fd = -1;
   isdaemon = 0;

   /*
    * We do our own input buffering.  We close the stdin file
    * pointer here so that we cannot use it accidentally.  If
    * we mix up buffered and unbuffered I/O reads we may mess
    * up the input stream without being aware we have done
    * so.  With stdin set to NULL, an error will occur if we
    * try to use it.
    */

   i = dup( 0 );
   fclose( stdin );
   stdin = NULL;

   if ( dup2( i, 0 ) < 0 )
   {
      fprintf( stderr, "initialize: dup2: %s.\n", strerror( errno ));
      exit( 1 );
   }

   close( i );

   signal( SIGCHLD, sigchld_handler );

   signal( SIGPIPE, SIG_IGN );
   signal( SIGHUP, SIG_DFL );
   signal( SIGINT, SIG_DFL );
   signal( SIGQUIT, SIG_DFL );

   signal( SIGTTIN, SIG_DFL );
   signal( SIGTTOU, SIG_DFL );
   signal( SIGTSTP, SIG_DFL );

   signal( SIGTERM, sigterm_handler );
   signal( SIGALRM, sigalrm_handler );
   signal( SIGWINCH, sigwinch_handler );

   if ( isatty( 1 ) &&
        setupterm( NULL, 1, &result ) == OK )
   {
      cl = tigetstr( "clear" );
      ce = tigetstr( "el" );
      cm = tigetstr( "cup" );
      vi = tigetstr( "civis" );
      ve = tigetstr( "cnorm" );
      sf = tigetstr( "ind" );
      sr = tigetstr( "ri" );
      al = tigetstr( "il1" );
      sc = tigetstr( "sc" );
      rc = tigetstr( "rc" );
      bd = tigetstr( "bold" );
      me = tigetstr( "sgr0" );
      af = tigetstr( "setaf" );
      ab = tigetstr( "setab" );
      nb = tigetstr( "rmso" );
   }

   history = make_stack();
   history_ptr = 0;

   string_stack = make_stack();

   if ( isatty( 0 ) )
   {
      if ( tcgetattr( 0, &canon_termios ) < 0 )
      {
         fprintf( stderr, "initialize: tcgetattr: %s.\n", strerror( errno ));
         exit( 1 );
      }
   }

   srandomdev();

   first_arg = arg_ptr = argv;
   last_arg = &argv[ argc - 1 ];

   result = regcomp( &merge_regex, "[^/]+$", REG_EXTENDED );

   if ( result )
   {
      regerror( result, &merge_regex, err, sizeof( err ));
      fprintf( stderr, "fatal error: initialize: merge_regex: regcomp(): %s.\n",
               err );
      exit( 1 );
   }

   /*
    * We tolerate contiguous delimiters because the system does, and has done so
    * since at least UNIX(TM) version 6, circa 1975.
    */

   result = regcomp( &find_poss_regex, "^(/*([^/]+/+)*)?([^/]+)?", REG_EXTENDED );

   if ( result )
   {
      regerror( result, &find_poss_regex, err, sizeof( err ));
      fprintf( stderr, "fatal error: initialize: regcomp(): %s.\n", err );
      exit( 1 );
   }

   env = memory( HASH_SIZE * sizeof( struct hash_elt * ));
   ptr = env;

   for( i = 0; i < HASH_SIZE; ++i )
      *ptr++ = NULL;

   syntax_items = 0;
   syntax_size = HASH_SIZE;
   syntax_resize = syntax_size * HASH_RESIZE;

   syntax = memory( syntax_size * sizeof( struct hash_elt * ));
   ptr = syntax;

   for( i = 0; i < syntax_size; ++i )
      *ptr++ = NULL;

   reclaimed_objects = ( struct stack *)memory( sizeof( struct stack ));
   reclaimed_objects->values = memory( sizeof( void * ) * POOL_INC );
   reclaimed_objects->free = POOL_INC;
   reclaimed_objects->used = 0;
   reclaimed_objects->top = reclaimed_objects->values;

   reclaimed_atoms = ( struct stack *)memory( sizeof( struct stack ));
   reclaimed_atoms->values = memory( sizeof( void * ) * POOL_INC );
   reclaimed_atoms->free = POOL_INC;
   reclaimed_atoms->used = 0;
   reclaimed_atoms->top = reclaimed_atoms->values;

   reclaimed_ids = ( struct stack *)memory( sizeof( struct stack ));
   reclaimed_ids->values = memory( sizeof( void * ) * POOL_INC );
   reclaimed_ids->free = POOL_INC;
   reclaimed_ids->used = 0;
   reclaimed_ids->top = reclaimed_ids->values;

   reclaimed_hash_elts = ( struct stack *)memory( sizeof( struct stack ));
   reclaimed_hash_elts->values = memory( sizeof( void * ) * POOL_INC );
   reclaimed_hash_elts->free = POOL_INC;
   reclaimed_hash_elts->used = 0;
   reclaimed_hash_elts->top = reclaimed_hash_elts->values;

   object_pool_stack = make_stack();
   object_pool = ( struct object *)memory( sizeof( struct object ) * POOL_INC );
   object_pool_ptr = object_pool;
   object_pool_free = POOL_INC;

   atom_pool_stack = make_stack();
   atom_pool = ( struct atom *)memory( sizeof( struct atom ) * POOL_INC );
   atom_pool_free = POOL_INC;
   atom_pool_ptr = atom_pool;

   hash_elt_pool_stack = make_stack();
   hash_elt_pool = ( struct hash_elt *)memory( sizeof( struct hash_elt ) * POOL_INC );
   hash_elt_pool_free = POOL_INC;
   hash_elt_pool_ptr = hash_elt_pool;

   stack = make_stack();
   open_envs = make_stack();

   bookmark_stack = make_stack();
   buffer_stack = make_stack();
   seen = make_stack();
   token = make_string();

   atom = get_id( "lambda", 6, 1 );
   atom->flags = ATOM_SYMBOL;
   lambda_id = atom->id;

   atom = get_id( "macro", 5, 1 );
   atom->flags = ATOM_SYMBOL;
   macro_id = atom->id;

   atom = get_id( "quote", 5, 1 );
   atom->flags = ATOM_SYMBOL;
   quote_id = atom->id;

   atom = get_id( "_", 1, 1 );
   atom->flags = ATOM_SYMBOL;
   underscore_id = atom->id;

   input_stack = make_stack();
   quotes_pending = make_stack();

   init_intrinsics();

   empty = make_atom_from_string( "", 0 );

   input_buffer_stack = make_stack();
   descriptors[ 0 ] = make_stack();
   descriptors[ 1 ] = make_stack();
   descriptors[ 2 ] = make_stack();

   result = 0;

   if ( stat( DATADIR "/library.munger", &stats ) == 0 )
      result = load( DATADIR "/library.munger" );
   else if ( stat( "./library.munger", &stats ) == 0 )
      result = load( "./library.munger" );
   else
      result = 1;

   if ( result )
      fprintf( stderr, "munger: cannot load library.munger\n" );

   STACK_POP( stack );

   ptr2 = getenv( "HOME" );

   if ( ptr2 != NULL )
   {
      s = make_string();
      string_assign( s, ptr2, strlen( ptr2 ));
      ptr2 = "/.munger";
      while( *ptr2 )
         STRING_APPEND( s, *ptr2++ )

      if ( stat( s->str, &stats ) == 0 )
      {
         if ( load( s->str ) && fatal )
            exit( 1 );

         STACK_POP( stack );
      }

      string_free( s );
   }

   if ( argc > 1 )
      if ( load( argv[ 1 ] ) && fatal )
         exit( 1 );
}

void stack_free( struct stack *a )
{
   free( a->values );
   free( a );
}

void free_objects()
{
   void *ptr;

   free( object_pool );

   while(( ptr = STACK_POP( object_pool_stack )) != NULL )
      free( ptr );

   stack_free( object_pool_stack );
}

void free_atoms()
{
   struct atom *ptr;

   free( atom_pool );

   while(( ptr = ( struct atom *)STACK_POP( atom_pool_stack )) != NULL )
      free( ptr );

   stack_free( atom_pool_stack );
}

void free_hash_elts()
{
   struct hash_elt *ptr;

   free( hash_elt_pool );

   while(( ptr = ( struct hash_elt *)STACK_POP( hash_elt_pool_stack )) != NULL )
      free( ptr );

   stack_free( hash_elt_pool_stack );
}

void close_descriptors()
{
   int i;

   for( i = 0; i < 3; ++i )
      while( descriptors[ i ]->used )
         resume( "cleanup", i );
}

void free_executables()
{
   if ( path != NULL )
   {
      free( path );
      path = NULL;
   }

   if ( executables != NULL )
   {
      while( executables->used )
      {
         STACK_POP( executables );
         STACK_POP( executables );
         free( STACK_POP( executables ));
      }

      stack_free( executables );
      executables = NULL;
   }
}

void free_history()
{
   while( history->used )
      free( STACK_POP( history ));

   stack_free( history );
}

/*
 * This function is not strictly necessary, as all resources will
 * be released upon exit.  It's useful for profiling.  In the call
 * graph I can see if I free everything malloced.
 */

/*
void cleanup()
{
   int i;

   free_executables();
   free_history();

   if ( syslog_name != NULL )
      free( syslog_name );

   do_child_close( "cleanup", NULL );
   close_descriptors();

   while( input_buffer_stack->used )
   {
      STACK_POP( input_buffer_stack );
      free( STACK_POP( input_buffer_stack ));
   }

   stack_free( input_buffer_stack );

   for( i = 0; i < 3; ++i )
   {
      stack_free( descriptors[ i ] );
      close( i );
   }

   while( bookmark_stack->used )
   {
      if ( bookmark_stack->top->ptr != NULL )
      {
         hash_free( ( struct hash_elt **)bookmark_stack->top->ptr, HASH_SIZE );
         free( ( struct hash_elt **)bookmark_stack->top->ptr );
      }

      STACK_POP( bookmark_stack );
   }

   stack_free( bookmark_stack );

   while( buffer_stack->used )
   {
      DB *db;

      db = ( DB *)STACK_POP( buffer_stack );
      if ( db != NULL )
         db->close( db );
   }

   stack_free( buffer_stack );

   hash_free( env, HASH_SIZE );
   hash_free( syntax, syntax_size );

   free( env );
   free( syntax );

   free_objects();
   free_atoms();

   free_syntax();
   free_hash_elts();

   stack_free( stack );
   stack_free( open_envs );

   stack_free( input_stack );
   stack_free( quotes_pending );

   stack_free( reclaimed_ids );
   stack_free( reclaimed_objects );
   stack_free( reclaimed_atoms );
   stack_free( reclaimed_hash_elts );

   string_free( token );
   stack_free( seen );
   stack_free( string_stack );

   regfree( &find_poss_regex );
   regfree( &merge_regex );
}
*/

void stack_push( struct stack *a, void *o )
{
   if ( a->free == 0 )
   {
      a->values = realloc( a->values, sizeof( union stack_u ) * ( a->used + stack_inc ) );

      if ( a->values == NULL )
      {
         fprintf( stderr, "realloc: %s.\n", strerror( errno ));
         exit( 1 );
      }

      a->free = stack_inc;
      a->top = &a->values[ a->used - 1 ];
   }

   if ( a->used )
      ++a->top;

   a->top->ptr = o;
   --a->free;
   ++a->used;
}

void stack_truncate( struct stack *a, long int i )
{
   while( i-- )
      STACK_POP( a );
}

void string_prepend( struct string *s, char c )
{
   char *ptr, *ptr2;

   if ( s->used == 0 )
   {
      STRING_APPEND( s, c )
      return;
   }

   if ( s->free == 0 )
   {
      s->str = ( char *)realloc( s->str, s->used + 1 + string_inc );

      if ( s->str == NULL )
      {
         fprintf( stderr, "string_prepend: realloc: %s.\n", strerror( errno ));
         exit( 1 );
      }

      /* Leave room for end-of-string sentinel. */

      s->free = string_inc - 1;
      s->top = &s->str[ s->used ];
   }

   ptr2 = &s->str[ s->used + 1 ];

   for( ptr = &s->str[ s->used ]; ptr >= s->str; --ptr )
      *ptr2-- = *ptr;

   s->str[ 0 ] = c;

   ++s->used;
   ++s->top;
   --s->free;
}

void string_append( struct string *s, char c )
{
   if ( s->free == 0 )
   {
      s->str = ( char *)realloc( s->str, s->used + 1 + string_inc );

      if ( s->str == NULL )
      {
         fprintf( stderr, "string_append: realloc: %s.\n", strerror( errno ));
         exit( 1 );
      }

      /* Leave room for end-of-string sentinel */

      s->free = string_inc;
      s->top = &s->str[ s->used ];
   }

   ++s->used;
   --s->free;
   *s->top++ = c;
   *s->top = '\0';
}

void string_erase( struct string *s, int idx )
{
   char *ptr, *ptr2;

   ptr = &s->str[ idx ];
   ptr2 = &s->str[ idx + 1 ];

   while( *ptr2 )
      *ptr++ = *ptr2++;

   *ptr = '\0';

   --s->used;
   ++s->free;
   --s->top;
}

void string_assign( struct string *s, char *c, int len )
{
   STRING_TRUNCATE( s )

   while( len-- )
      STRING_APPEND( s, *c++ )
}

int get_token( int depth, int file )
{
   static char characters[ 131072 ] = "", stdin_buffer[ 131072 ] ="";
   static char *ptr = characters;
   static int count = 1;
   static int old_file = -1;
   static int escape = 0;
   int type;

   if ( file == -1 )
   {
      *characters = '\0';
      ptr = characters;
      old_file = -1;
      return -1;
   }

   type = -1;
   STRING_TRUNCATE( token )

   if ( old_file != file )
   {
      char *tmp = NULL;

      if ( old_file == 0 )
         strcpy( stdin_buffer, ptr );
      else if ( old_file > 0 )
      {
         int pos = -( strlen( ptr ));
         lseek( old_file, pos, SEEK_CUR );
      }

      if ( old_file < -1 )
         tmp = ptr;

      if ( file == 0 )
         ptr = stdin_buffer;
      else if ( file < -1 )
         ptr = ( char *)STACK_POP( string_stack );
      else
      {
         *characters = '\0';
         ptr = characters;
      }

      if ( old_file < -1 )
         STACK_PUSH( string_stack, ( void *)tmp )
   }

   old_file = file;

   for( ; ; )
   {
      int i;

      if ( *ptr == '\0' )
      {
         if ( file == 0 )
         {
            if ( isatty( fileno( stdout )))
            {
               fputs( ">", stdout );

               i = depth;
               while( i-- > 0 )
                  fputs( ">", stdout );

               fputs( " ", stdout );
            }

            fflush( stdout );
         }

   AGAIN:
         if ( file < -1 || ( count = read( file, characters, sizeof( characters ) - 1 )) == 0 )
         {
            if ( type >= 0 )
               return type;

            old_file = -1;
            return TOK_END;
         }

         if ( count == -1 )
         {
            if ( errno == EINTR || errno == EAGAIN )
               goto AGAIN;

            fprintf( stderr, "read: %s.\n", strerror( errno ));
            exit( 1 );
         }

         characters[ count ] = '\0';
         ptr = characters;
      }

      for( ; *ptr; )
      {
         if ( type == TOK_COMMENT )
         {
            if ( *ptr == '\n' || *ptr == '\r' )
            {
               STRING_TRUNCATE( token )
               type = -1;
            }

            ++ptr;
            continue;
         }

         if ( type == TOK_STRING && escape && *ptr != '\\' && *ptr != '"' )
            escape = 0;

         if ( *ptr == '\\' )
         {
            if ( type != TOK_STRING )
            {
               ++ptr;
               continue;
            }

            if ( !( escape ^= 1 ) )
               STRING_CHOP( token )
         }

         if ( *ptr == ';' || *ptr == '#' )
         {
            if ( type < 0 )
               type = TOK_COMMENT;
            else if ( type != TOK_STRING )
               return type;

            STRING_APPEND( token, *ptr++ )
            continue;
         }

         if ( *ptr == '(' || *ptr == ')' )
         {
            if ( type >= 0 )
            {
               if ( type == TOK_STRING )
               {
                  STRING_APPEND( token, *ptr++ )
                  continue;
               }

               return type;
            }

            type = ( *ptr == '(' ? TOK_OPEN : TOK_CLOSE );
            STRING_APPEND( token, *ptr++ )
            return type;
         }

         if ( *ptr == '"' )
         {
            if ( type < 0 )
            {
               type = TOK_STRING;
               STRING_APPEND( token, *ptr++ )
               continue;
            }

            if ( type != TOK_STRING )
               return type;

            if ( escape )
               STRING_CHOP( token )

            STRING_APPEND( token, *ptr++ )

            if ( !escape )
               return type;

            escape = 0;
            continue;
         }

         if (( *ptr >= 'A' && *ptr <= 'Z' ) ||
             ( *ptr >= 'a' && *ptr <= 'z' ) || *ptr == '_' )
         {
            if ( type == -1 )
               type = TOK_SYMBOL;
            else if ( type != TOK_STRING && type != TOK_SYMBOL )
               return type;

            STRING_APPEND( token, *ptr++ )
            continue;
         }

         if ( *ptr >= '0' && *ptr <= '9' )
         {
            if ( type == -1 || type == TOK_MINUS )
               type = TOK_FIXNUM ;
            else if ( type != TOK_STRING && type != TOK_SYMBOL &&
                      type != TOK_FIXNUM )
               return type;

            STRING_APPEND( token, *ptr++ )
            continue;
         }

         if ( !isspace( *ptr ))
         {
            if ( type == -1 )
            {
               if ( *ptr == '\'' )
                  type = TOK_QUOTE;
               else if ( *ptr == '-' )
                  type = TOK_MINUS;
               else
                  type = TOK_SPECIAL;
            }
            else if ( type != TOK_STRING &&
                      type != TOK_SPECIAL )
               return type;

            STRING_APPEND( token, *ptr++ )
            continue;
         }

         if ( type < 0 )
         {
            ++ptr;
            continue;
         }

         if ( type != TOK_STRING )
            return type;

         if ( *ptr == '\r' )
         {
            if ( isatty( 0 ))
               STRING_APPEND( token, '\n' )
            else
               STRING_APPEND( token, *ptr++ )

            continue;
         }

         STRING_APPEND( token, *ptr++ )
      }
   }

   return type;
}

int process_token( int type, int depth )
{
   struct object *ptr;
   static int quote = -2;

   if ( type == TOK_OPEN )
   {
      if ( quote == -1 )
         quote = depth;

      ++depth;

      ptr = make_object();
      ptr->flags = -1;
      STACK_PUSH( input_stack, ptr )

      return depth;
   }

   if ( type == TOK_QUOTE )
   {
      string_assign( token, "(", 1 );
      depth = process_token( TOK_OPEN, depth );

      string_assign( token, "quote", 5 );
      process_token( TOK_SYMBOL, depth );

      if ( quote > 0 )
         STACK_PUSH_INT( quotes_pending, quote )

      quote = -1;
      return depth;
   }

   if ( type == TOK_CLOSE )
   {
      if ( --depth < 0 )
         return depth;

      if ((( struct object *)input_stack->top->ptr )->flags == -1 )
          (( struct object *)input_stack->top->ptr )->flags = 1;
      else
      {
         for( ; input_stack->used; )
         {
            ptr = STACK_POP( input_stack );

            if ((( struct object *)input_stack->top->ptr )->flags == -1 )
            {
               (( struct object *)input_stack->top->ptr )->flags = 1;
               (( struct object *)input_stack->top->ptr )->data.head = ptr;
               break;
            }
            else
               (( struct object *)input_stack->top->ptr )->next = ptr;
         }
      }

      if ( quote == depth )
      {
         if ( quotes_pending->used )
            quote = STACK_POP_INT( quotes_pending );
         else
            quote = -2;

         string_assign( token, ")", 1 );
         depth = process_token( TOK_CLOSE, depth );
      }
      else if ( depth == 0 )
         STACK_PUSH( stack, STACK_POP( input_stack ))

      return depth;
   }

   ptr = make_object();

   if ( type == TOK_FIXNUM )
   {
      setnumber( ptr->flags );
      ptr->data.number = strtol( token->str, NULL, 10 );
   }
   else
   {
      struct atom *entry;

      if ( type == TOK_STRING )
         STRING_CHOP( token )

      entry = get_id( token->str, token->used, 1 );

      switch( type )
      {
         case TOK_STRING:
            entry->flags = ATOM_STRING;
            entry->data.string = memory( sizeof( struct lstring ));
            entry->data.string->string = &entry->syntax[ 1 ];
            entry->data.string->length = token->used - 1;
            break;

         case TOK_SYMBOL:
         case TOK_SPECIAL:
            entry->flags = ATOM_SYMBOL;
            entry->data.record = NULL;
            break;
      }

      ptr->data.atom = entry;
   }

   STACK_PUSH(( depth ? input_stack : stack ), ptr )

   if ( quote == -1 )
   {
      if ( quotes_pending->used )
         quote = STACK_POP_INT( quotes_pending );
      else
         quote = -2;

      string_assign( token, ")", 1 );
      depth = process_token( TOK_CLOSE, depth );
   }

   return depth;
}

int parse( int file )
{
   int depth = 0;

   for( ; ; )
   {
      int type;

      type = get_token( depth, file );

      if ( type == TOK_END )
         return 1;

      depth = process_token( type, depth );

      if ( depth <= 0 )
         break;
   }

   return depth;
}

void do_printing( struct object *ptr, int recursive )
{
   while( ptr != NULL )
   {
      if ( islist( ptr->flags ) )
      {
         fputc( '(', stdout );
         do_printing( ptr->data.head, 1 );
         fputc( ')', stdout );
      }
      else if ( numberp( ptr->flags ))
         printf( "%li", ptr->data.number );
      else
      {
         fwrite( ptr->data.atom->syntax, ptr->data.atom->len, 1, stdout );

         if ( type( ptr->data.atom->flags ) == ATOM_STRING )
            fputc( '"', stdout );
      }

      if ( recursive == 0 )
         break;

      if (( ptr = ptr->next ) != NULL )
         fputc( ' ', stdout );
   }
}

struct object *make_atom_from_closure( struct closure *closure, int macro )
{
   struct atom *entry;
   struct object *obj;
   char buffer[ 128 ], *t;
   int len;

   t = ( macro ? "<MACRO_CLOSURE#%d>" : "<CLOSURE#%d>" );

   len = snprintf( buffer, sizeof( buffer ), t, closure_counter++ );
   entry = get_id( buffer, len, 1 );

   entry->flags = ( macro ? ATOM_MACRO : ATOM_CLOSURE );
   entry->data.closure = closure;

   obj = make_object();
   obj->data.atom = entry;

   return obj;
}

struct object *make_atom_from_act_record( struct stack *act_record )
{
   struct atom *entry;
   struct object *obj;
   char buffer[ 128 ];
   int len;

   len = snprintf( buffer, sizeof( buffer ), "<ACT_RECORD#%d>", act_record_counter++ );
   entry = get_id( buffer, len, 1 );

   entry->flags = ATOM_ACT_RECORD;
   entry->data.act_record = act_record;

   obj = make_object();
   obj->data.atom = entry;

   return obj;
}

int make_act_record( struct object *args, struct closure *closure, struct stack *act_record,
                     char *name, int eval_args  )
{
   int i, j, sym_count = 0, arg_count = 0;
   char *more = "";
   struct object *ptr, *ptr2;

   STACK_PUSH( act_record, closure->env )

   for( ptr = closure->text->data.head; ptr != NULL; ptr = ptr->next )
   {
      if ( ptr->next == NULL && islist( ptr->flags ))
         more = "(at least)";

      ++sym_count;
   }

   if ( sym_count && args == NULL && *more == '\0' )
   {
      fprintf( stderr, "%s: 0 argument(s) given to closure "
               "expecting %s %d argument(s).\n", name, more, sym_count );
      return 1;
   }

   for( ptr = args; ptr != NULL; ptr = ptr->next )
      ++arg_count;

   if ( sym_count != arg_count )
   {
      if ( *more == '\0' || ( arg_count < sym_count - 1 ))
      {
         fprintf( stderr, "%s: %d argument(s) given to closure"
                  " expecting %s %d argument(s).\n",
                  name, arg_count, more, sym_count );
         return 1;
      }
   }

   if ( *more == '\0' )
   {
      if ( arg_count )
      {
         for( i = 1, ptr = closure->text->data.head, ptr2 = args;
              i <= arg_count;
              ptr = ptr->next, ptr2 = ptr2->next, ++i )
         {
            if ( eval_args )
            {
               STACK_PUSH( stack, ptr2 )

               if ( evaluate() )
               {
                  if ( !stop )
                     fprintf( stderr, "%s: evaluation of argument %d failed.\n",
                              name, i );
                  return 1;
               }
            }
            else
            {
               STACK_PUSH( act_record, ptr2 )
               STACK_PUSH_INT( act_record, ptr->data.atom->id )
            }
         }

         if ( eval_args )
         {
            for( j = i - 1, i = 1, ptr = closure->text->data.head; i <= arg_count; ptr = ptr->next, ++i, --j )
            {
               STACK_PUSH( act_record, stack->values[ stack->used - j ].ptr )
               STACK_PUSH_INT( act_record, ptr->data.atom->id )
            }

            stack_truncate( stack, i - 1 );
         }
      }
   }
   else
   {
      struct object *result;

      if ( arg_count == 0 )
      {
         result = make_object();
         setlist( result->flags );
         STACK_PUSH( act_record, result )
         STACK_PUSH_INT( act_record, closure->text->data.head->data.head->data.atom->id )
      }
      else
      {
         struct object **ptr3;

         for( i = 1, ptr = closure->text->data.head, ptr2 = args;
              i < sym_count;
              ptr = ptr->next, ptr2 = ptr2->next, ++i )
         {
            if ( eval_args )
            {
               STACK_PUSH( stack, ptr2 )

               if ( evaluate() )
               {
                  if ( !stop )
                     fprintf( stderr, "%s: evaluation of argument %d failed.\n", name, i );
                  return 1;
               }
            }
            else
            {
               STACK_PUSH( act_record, ptr2 )
               STACK_PUSH_INT( act_record, ptr->data.atom->id )
            }
         }

         if ( i > 1 && eval_args )
         {
            for( j = i - 1, i = 1, ptr = closure->text->data.head; i < sym_count; ptr = ptr->next, ++i, --j )
            {
               STACK_PUSH( act_record, stack->values[ stack->used - j ].ptr )
               STACK_PUSH_INT( act_record, ptr->data.atom->id )
            }

            stack_truncate( stack, i - 1 );
         }

         result = make_object();
         setlist( result->flags );
         STACK_PUSH( stack, result )
         STACK_PUSH( act_record, result )
         STACK_PUSH_INT( act_record, ptr->data.head->data.atom->id )

         ptr3 = &result->data.head;

         if ( ptr2 != NULL )
         {
            for( j = 1; ptr2 != NULL; ptr2 = ptr2->next, ++i, ++j )
            {
               if ( eval_args )
               {
                  STACK_PUSH( stack, ptr2 )

                  if ( evaluate() )
                  {
                     if ( !stop )
                        fprintf( stderr, "%s: evaluation of argument %d failed.\n", name, i );
                     return 1;
                  }
               }
               else
               {
                  *ptr3 = ptr2;
                  ptr3 = &( *ptr3 )->next;
               }
            }

            if ( eval_args )
            {
               ptr3 = &result->data.head;

               i = --j;

               for( ; j > 0; --j )
               {
                  *ptr3 = duplicate_object( stack->values[ stack->used - j ].ptr );
                  ptr3 = &( *ptr3 )->next;
               }

               stack_truncate( stack, i );
            }
         }

         STACK_POP( stack );

         *ptr3 = NULL;
      }
   }

   return 0;
}

int evaluate_body( struct object *args, int *fail )
{
   struct object *ptr, *item = NULL;
   int count = 0, result = 0;

   for( ptr = args; ptr != NULL; ptr = ptr->next )
   {
      ++count;

      STACK_PUSH( stack, ptr )

      /*
       * Don't bother evaluating constants.
       */

      if (! (( islist( ptr->flags ) && ptr->data.head == NULL )

             ||

            ( islist( ptr->flags ) == 0 &&
              ( numberp( ptr->flags ) ||
                ptr->data.atom->id == lambda_id ||
                ptr->data.atom->id == macro_id  ||
                type( ptr->data.atom->flags ) != ATOM_SYMBOL ))))
      {
         /*
          * The only atoms to make it here are symbols.
          */

         if ( islist( ptr->flags ) == 0 )
         {
            struct stack *local;
            struct object *env_ptr, *value;
            union stack_u *ptr2;

            value = NULL;

            for( env_ptr = local_env;
                 env_ptr != NULL;
                 env_ptr = ( struct object *)local->values[ 0 ].ptr )
            {
               local = env_ptr->data.atom->data.act_record;

               for( ptr2 = local->top; ptr2 > local->values; ptr2 -= 2 )
                  if ( ptr2->integer == ptr->data.atom->id )
                  {
                     value = ( --ptr2 )->ptr;
                     goto FOUND;
                  }
            }

            value = lookup_binding( ptr->data.atom );

            if ( value == NULL )
            {
               fprintf( stderr, "evaluate: symbol %s not bound.\n",
                        ptr->data.atom->syntax );
               *fail = count;
               return 1;
            }

         FOUND:
            stack->top->ptr = value;
         }
         else
         {
            char *name = NULL;
            int sym = 0, t, evaluated = 0;
      #ifdef DEBUG
            long int level = 0;
      #endif
            struct object *car, *cdr;

            car = ptr->data.head;
            cdr = ptr->data.head->next;

            if ( islist( car->flags ) == 0 &&
                 numberp( car->flags ) == 0 &&
                 ( sym = ( type( car->data.atom->flags ) == ATOM_SYMBOL )))
            {
               if ( car->data.atom->id == lambda_id )
               {
                  result = create_closure( cdr, 0 );
                  goto DONE;
               }
               else if ( car->data.atom->id == macro_id )
               {
                  result = create_closure( cdr, 1 );
                  goto DONE;
               }
            }

            /*
             * Avoid a recursive call to lookup symbols in function position.
             */

            if ( sym )
            {
               struct stack *local;
               struct object *env_ptr, *value;
               union stack_u *ptr;

               name = car->data.atom->syntax;
               value = NULL;

               for( env_ptr = local_env;
                    env_ptr != NULL;
                    env_ptr = ( struct object *)local->values[ 0 ].ptr )
               {
                  local = env_ptr->data.atom->data.act_record;

                  for( ptr = local->top; ptr > local->values; ptr -= 2 )
                     if ( ptr->integer == car->data.atom->id )
                     {
                        value = ( --ptr )->ptr;
                        goto FOUND_1;
                     }
               }

               value = lookup_binding( car->data.atom );

               if ( value == NULL )
               {
                  fprintf( stderr, "evaluate: symbol %s not bound.\n", name );
                  *fail = count;
                  return 1;
               }

            FOUND_1:
               car = value;
            }
            else
            {
               STACK_PUSH( stack, car )

               if ( evaluate() )
               {
                  *fail = count;
                  return 1;
               }

               car = stack->top->ptr;
               evaluated = 1;
            }

            if ( islist( car->flags ) || numberp( car->flags ))
            {
               func_err( car );
               *fail = count;
               return 1;
            }

#ifdef DEBUG
   level = stack->used;
#endif
            t = type( car->data.atom->flags );

            switch( t )
            {
               case ATOM_INTRINSIC:

#ifdef DEBUG_FUNCTIONS
   fprintf( stderr, "[invoking intrinsic %s]\n", ( name == NULL ? car->data.atom->syntax : name ));
#endif

                  if ( car->data.atom->data.function == do_quote )
                  {
                     if ( cdr == NULL )
                     {
                        print_err( ERR_MISSING_ARGS, name, 0, -1 );
                        result = 1;
                     }
                     else if ( cdr->next != NULL )
                     {
                        print_err( ERR_MORE_ARGS, name, 1, -1 );
                        result = 1;
                     }
                     else
                     {
                        STACK_PUSH( stack, cdr )
                        result = 0;
                     }
                  }
                  else
                     result = car->data.atom->data.function( car->data.atom->syntax, cdr );
                  break;

               case ATOM_CLOSURE:

#ifdef DEBUG_FUNCTIONS
   fprintf( stderr, "[applying function %s]\n", ( name == NULL ? car->data.atom->syntax : name ));
#endif

                  result = apply_closure( ( name == NULL ? car->data.atom->syntax : name ),
                                          car->data.atom->data.closure,
                                          cdr,
                                          1 );
                  break;

               case ATOM_MACRO:

#ifdef DEBUG_FUNCTIONS
   fprintf( stderr, "[applying macro %s]\n", ( name == NULL ? car->data.atom->syntax : name ));
#endif

                  if (( result = apply_closure( ( name == NULL ? car->data.atom->syntax : name ),
                                                car->data.atom->data.closure,
                                                cdr,
                                                0 )) == 0 &&
                      ( result = evaluate()) && !stop )
                         fputs( "secondary evaluation of macro failed.\n", stderr );
                  break;

               default:
                  func_err( car );
                  *fail = count;
                  return 1;
            }

#ifdef DEBUG
   if ( ! result && level != stack->used - 1 )
   {
      fprintf( stderr, "[stack corrupted by: %s: before: %ld, after: %ld\n]",
               ( name == NULL ? car->data.atom->syntax : name ),
               level, stack->used );
      exit( 1 );
   }
#endif

            if ( ! result || next_iteration )
            {
               if ( ! next_iteration )
                  stack->values[ stack->used - ( 2 + evaluated ) ] = *stack->top;

               if ( evaluated )
               {
                  --stack->top;
                  ++stack->free;
                  --stack->used;
               }

               --stack->top;
               ++stack->free;
               --stack->used;
            }

         DONE:
            if ( result )
            {
               if ( !stop )
                  print_err( ERR_EVAL, name, 1, -1 );

               *fail = count;
               return 1;
            }
         }
      }

      item = STACK_POP( stack );
   }

   if ( ! result )
      STACK_PUSH( stack, item );

   return result;
}

int apply_closure( char *name, struct closure *closure, struct object *args, int eval_args )
{
   struct object *obj;
   struct closure *old_closure;
   struct stack *act_record;
   int returned = 0, i, j;

   act_record = make_stack();

   if ( make_act_record( args, closure, act_record, name, eval_args ))
      return 1;

   obj = make_atom_from_act_record( act_record );

   old_closure = current_closure;
   current_closure = closure;

   STACK_PUSH( open_envs, local_env )
   local_env = obj;

   i = stack->used;

TAILCALL:
   if (( returned = evaluate_body( current_closure->text->next, &j )))
   {
      if ( !stop )
         fprintf( stderr, "%s: evaluation of body expression %d failed.\n", name, j );
   }

   if ( returned && tailcall )
   {
      stack_truncate( stack, stack->used - i );
      tailcall = 0;

      name = tailcall_syntax;
      tailcall_syntax = NULL;

      stop = 0;
      goto TAILCALL;
   }

   local_env = STACK_POP( open_envs );
   current_closure = old_closure;

   return returned;
}

struct object *lookup_local( int id )
{
   struct stack *local;
   struct object *env_ptr;
   union stack_u *ptr;

   for( env_ptr = local_env;
        env_ptr != NULL;
        env_ptr = ( struct object *)local->values[ 0 ].ptr )
   {
      local = env_ptr->data.atom->data.act_record;

      for( ptr = local->top; ptr > local->values; ptr -= 2 )
         if ( ptr->integer == id )
            return ( --ptr )->ptr;
   }

   return NULL;
}

int set_local( int id, struct object *obj )
{
   struct stack *local;
   struct object *env_ptr;
   union stack_u *ptr;

   for( env_ptr = local_env;
        env_ptr != NULL;
        env_ptr = ( struct object *)local->values[ 0 ].ptr )
   {
      local = env_ptr->data.atom->data.act_record;

      for( ptr = local->top;
           ptr > local->values;
           ptr -= 2 )
         if ( ptr->integer == id )
         {
            ( --ptr )->ptr = obj;
            return 0;
         }
   }

   return 1;
}

int create_closure( struct object *func, int macro )
{
   struct closure *closure;
   struct object *ptr;
   char *syntax = "create_closure";

   if ( islist( func->flags ) == 0 )
   {
      fprintf( stderr, "%s: missing parameter list.\n", syntax );
      return 1;
   }

   if ( func->next == NULL )
   {
      fprintf( stderr, "%s: missing function body.\n", syntax );
      return 1;
   }

   for( ptr = func->data.head; ptr != NULL; ptr = ptr->next )
   {
      if ( islist( ptr->flags ))
      {
         struct object *ptr2;

         if ( ptr->next != NULL )
         {
            fprintf( stderr, "%s: sublist in non-terminal position "
                             "of parameter list", syntax );
            return 1;
         }

         ptr2 = ptr->data.head;

         if ( islist( ptr2->flags ) ||
              type( ptr2->data.atom->flags ) != ATOM_SYMBOL )
         {
            fprintf( stderr, "%s: non-symbol in optional parameter sublist.\n",
                     syntax );
            return 1;
         }

         if ( ptr2->next != NULL )
         {
            fprintf( stderr, "%s: optional parameter sublist has more than 1"
                             "element.\n", syntax );
            return 1;
         }
      }
      else if ( type( ptr->data.atom->flags ) != ATOM_SYMBOL )
      {
         fprintf( stderr, "%s: non-symbol in parameter list.\n", syntax );
         return 1;
      }
   }

   closure = ( struct closure *)memory( sizeof( struct closure ) );
   closure->text = func;
   closure->env = local_env;

   stack->top->ptr = make_atom_from_closure( closure, macro );

   return 0;
}

void func_err( struct object *car )
{
   fputs( "evaluate: ", stderr );

   if ( islist( car->flags ))
      fputs( "function position evaluated to a list.\n", stderr );
   else if ( numberp( car->flags ))
      fputs( "function position evaluated to a fixnum.\n", stderr );
   else
   {
      fputs( "function position evaluated to: ", stderr );
      fputs( car->data.atom->syntax, stderr );
      if ( type( car->data.atom->flags ) == ATOM_STRING )
         fputc( '"', stderr );
      fputc( '\n', stderr );
   }
}

int evaluate()
{
   int result = 0;
   struct object *value, *item;

   if ((( objects_allocated - objects_at_last_collect ) > GC_FREQ ||
        ( atoms_allocated - atoms_at_last_collect ) > GC_FREQ ))
   {
      collect_garbage();
      objects_at_last_collect = objects_allocated;
      atoms_at_last_collect = atoms_allocated;
   }

   if ( stack->used == 0 )
      return 1;

   item = stack->top->ptr;

   /*
    * Don't bother evaluating constants.
    */

   if (( islist( item->flags ) && item->data.head == NULL )

          ||

         ( islist( item->flags ) == 0 &&
           ( numberp( item->flags ) ||
             item->data.atom->id == lambda_id ||
             item->data.atom->id == macro_id  ||
             type( item->data.atom->flags ) != ATOM_SYMBOL )))

      return 0;

   /*
    * The only atoms to make it this far are symbols.
    */

   if ( islist( item->flags ) == 0 )
   {
      struct stack *local;
      struct object *env_ptr;
      union stack_u *ptr;

      value = NULL;

      for( env_ptr = local_env;
           env_ptr != NULL;
           env_ptr = ( struct object *)local->values[ 0 ].ptr )
      {
         local = env_ptr->data.atom->data.act_record;

         for( ptr = local->top; ptr > local->values; ptr -= 2 )
            if ( ptr->integer == item->data.atom->id )
            {
               value = ( --ptr )->ptr;
               goto FOUND_0;
            }
      }

      value = lookup_binding( item->data.atom );

      if ( value == NULL )
      {
         fprintf( stderr, "evaluate: symbol %s not bound.\n",
                  item->data.atom->syntax );
         return 1;
      }

   FOUND_0:
      stack->top->ptr = value;
   }
   else
   {
      int t, evaluated = 0;
      char *name = NULL;
      int sym = 0;
#ifdef DEBUG
      long int level = 0;
#endif
      struct object *car, *cdr;

      car = item->data.head;
      cdr = item->data.head->next;

      if ( islist( car->flags ) == 0 &&
           numberp( car->flags ) == 0 &&
           ( sym = ( type( car->data.atom->flags ) == ATOM_SYMBOL )))
      {
         if ( car->data.atom->id == lambda_id )
            return create_closure( cdr, 0 );
         else if ( car->data.atom->id == macro_id )
            return create_closure( cdr, 1 );
      }

      /*
       * Avoid a recursive call to lookup symbols in function position.
       */

      if ( sym )
      {
         struct stack *local;
         struct object *env_ptr;
         union stack_u *ptr;

         name = car->data.atom->syntax;
         value = NULL;

         for( env_ptr = local_env;
              env_ptr != NULL;
              env_ptr = ( struct object *)local->values[ 0 ].ptr )
         {
            local = env_ptr->data.atom->data.act_record;

            for( ptr = local->top; ptr > local->values; ptr -= 2 )
               if ( ptr->integer == car->data.atom->id )
               {
                  value = ( --ptr )->ptr;
                  goto FOUND_1;
               }
         }

         value = lookup_binding( car->data.atom );

         if ( value == NULL )
         {
            fprintf( stderr, "evaluate: symbol %s not bound.\n", name );
            return 1;
         }

      FOUND_1:
         car = value;
      }
      else
      {
         STACK_PUSH( stack, car )

         if ( evaluate() )
            return 1;

         car = stack->top->ptr;
         evaluated = 1;
      }

      if ( islist( car->flags ) || numberp( car->flags ))
      {
         func_err( car );
         return 1;
      }

#ifdef DEBUG
      level = stack->used;
#endif
      t = type( car->data.atom->flags );

      switch( t )
      {
         case ATOM_INTRINSIC:

#ifdef DEBUG_FUNCTIONS
   fprintf( stderr, "[invoking intrinsic %s]\n", ( name == NULL ? car->data.atom->syntax : name ));
#endif

            if ( car->data.atom->data.function == do_quote )
            {
               if ( cdr == NULL )
               {
                  print_err( ERR_MISSING_ARGS, name, 0, -1 );
                  result = 1;
               }
               else if ( cdr->next != NULL )
               {
                  print_err( ERR_MORE_ARGS, name, 1, -1 );
                  result = 1;
               }
               else
               {
                  STACK_PUSH( stack, cdr )
                  result = 0;
               }
            }
            else
               result = car->data.atom->data.function( car->data.atom->syntax, cdr );
            break;

         case ATOM_CLOSURE:

#ifdef DEBUG_FUNCTIONS
   fprintf( stderr, "[applying function %s]\n", ( name == NULL ? car->data.atom->syntax : name ));
#endif

            result = apply_closure(( name == NULL ? car->data.atom->syntax : name ),
                                    car->data.atom->data.closure,
                                    cdr,
                                    1 );
            break;

         case ATOM_MACRO:

#ifdef DEBUG_FUNCTIONS
   fprintf( stderr, "[applying macro %s]\n", ( name == NULL ? car->data.atom->syntax : name ));
#endif

            if (( result = apply_closure(( name == NULL ? car->data.atom->syntax : name ),
                                          car->data.atom->data.closure,
                                          cdr,
                                          0 )) == 0 &&
                ( result = evaluate()) && !stop )
               fputs( "secondary evaluation of macro failed.\n", stderr );
            break;

         default:
            func_err( car );
            return 1;
      }

#ifdef DEBUG
      if ( ! result && level != stack->used - 1 )
      {
         fprintf( stderr, "stack corrupted by: %s: before: %ld, after: %ld\n",
                  ( name == NULL ? car->data.atom->syntax : name ),
                  level, stack->used );
         exit( 1 );
      }
#endif

      if ( ! result || next_iteration )
      {
         if ( ! next_iteration )
            stack->values[ stack->used - ( 2 + evaluated ) ] = *stack->top;

         if ( evaluated )
         {
            --stack->top;
            ++stack->free;
            --stack->used;
         }

         --stack->top;
         ++stack->free;
         --stack->used;
      }
   }

   return result;
}

void toplevel()
{
   char *t = "toplevel";
   int result;

   if ( isatty( 0 ))
      printf( "---------------------------------\n"
              "Munger %d.%d\nCopyright 2001-2026, "
              "James Bailie\nmammothcheese.ca\n"
              "---------------------------------\n\n",
              VERSION_MAJOR, VERSION_MINOR );

#ifdef DEBUG
   puts( "[DEBUG build]\n" );
#endif

   for( ; ; )
   {
      int depth;

      stack->free += stack->used;
      stack->used = 0;
      stack->top = stack->values;

      if ( tty_mode == 0 )
         canon( t );

      fflush( stdout );
      depth = parse( 0 );

      if ( depth > 0 )
         break;
      else if ( depth < 0 )
      {
         fprintf( stderr, "%s: %d extra ')'\n", t, -depth );

         if ( fatal )
            exit( 1 );
      }

      result = evaluate();
      close_descriptors();

      if ( result == 0 )
      {
         if ( printer )
         {
            print_object( *( struct object **)stack->top );
            putchar( '\n' );
         }
      }
      else if ( thrown != NULL )
         fprintf( stderr, "%s: uncaught \"throw\"\n", t );
      else if ( next_iteration )
         fprintf( stderr, "%s: \"continue\" used outside of loop\n", t );

      if ( fatal )
         exit( 1 );

      thrown = NULL;
      stop = next_iteration = 0;
   }
}

void mark_record( union stack_u *record )
{
   int total, i;
   union stack_u *ptr;

   for( i = 0; i < seen->used; ++i )
      if ( seen->values[ i ].ptr == record )
         return;

   total = record[ 0 ].integer;

   ptr = record;

   for( i = 0; i < total; ++i )
      mark_object( ( ++ptr )->ptr );
}

void mark_object( struct object *obj )
{
   if ( obj == NULL )
      return;

   mark( obj->flags );

   if ( islist( obj->flags ) )
      mark_list( obj->data.head );
   else if ( numberp( obj->flags ) == 0 )
   {
      set( obj->data.atom->flags );

      switch( type( obj->data.atom->flags ))
      {
         case ATOM_TABLE:
            mark_table( obj->data.atom->data.table->hash, obj->data.atom->data.table->size );
            break;

         case ATOM_STACK:
            mark_stack( obj->data.atom->data.stack );
            break;

         case ATOM_CLOSURE:
         case ATOM_MACRO:
            mark_closure( obj->data.atom->data.closure );
            break;

         case ATOM_ACT_RECORD:
            mark_act_record( obj->data.atom->data.act_record );
            break;

         case ATOM_RECORD:
            mark_record( obj->data.atom->data.record );
      }
   }
}

void mark_act_record( struct stack *act_record )
{
   int i;

   for( i = 0; i < seen->used; ++i )
      if ( seen->values[ i ].ptr == act_record )
         return;

   STACK_PUSH( seen, act_record )

   mark_object( ( struct object *)act_record->values[ 0 ].ptr );

   for( i = 1; i < act_record->used; i += 2 )
      mark_object( ( struct object *)act_record->values[ i ].ptr );
}

void mark_closure( struct closure *closure )
{
   if ( closure == NULL )
      return;

   mark_list( closure->text );
   mark_object( closure->env );
}

void mark_stack( struct stack *stk )
{
   int i;

   if ( ! stk->used )
      return;

   for( i = 0; i < seen->used; ++i )
      if ( seen->values[ i ].ptr == stk )
         return;

   STACK_PUSH( seen, stk )

   for( i = 0; i < stk->used; ++i )
      mark_object( ( struct object *)stk->values[ i ].ptr );
}

void mark_table( struct hash_elt **hash, int size )
{
   struct hash_elt **ptr, *ptr2;
   int i;

   for( i = 0; i < seen->used; ++i )
      if ( seen->values[ i ].ptr == hash )
         return;

   STACK_PUSH( seen, hash )

   for( ptr = hash, i = 0; i < size; ++i, ++ptr )
   {
      if ( *ptr == NULL )
         continue;

      for( ptr2 = *ptr; ptr2 != NULL; ptr2 = ptr2->next )
      {
         set( ptr2->key->flags );
         mark_object((( struct object *)ptr2->element.ptr ));
      }
   }
}

void mark_list( struct object *ptr )
{
   while( ptr != NULL )
   {
      mark_object( ptr );
      ptr = ptr->next;
   }
}

void sweep_objects()
{
   struct object *top;
   int i, j, old_stack_inc;

   reclaimed_objects->free += reclaimed_objects->used;
   reclaimed_objects->used = 0;
   reclaimed_objects->top = reclaimed_objects->values;
   
   old_stack_inc = stack_inc;
   stack_inc = 65536;

   i = object_pool_stack->used;

   while( i )
   {
      top = ( struct object *)object_pool_stack->values[ --i ].ptr;

      for( j = 0; j < POOL_INC; ++j, ++top )
      {
         if ( ! ismarked( top->flags ) && ( top->flags || top->data.atom != NULL ))
         {
            --objects_allocated;
            bzero( top, sizeof( struct object ));
            STACK_PUSH( reclaimed_objects, top )
            continue;
         }

         unmark( top->flags );
      }
   }

   for( top = object_pool; top < object_pool_ptr; ++top )
   {
      if ( ! ismarked( top->flags ) && ( top->flags || top->data.atom != NULL ))
      {
         --objects_allocated;
         bzero( top, sizeof( struct object ));
         STACK_PUSH( reclaimed_objects, top )
         continue;
      }

      unmark( top->flags );
   }

   stack_inc = old_stack_inc;
}

void free_atom( struct atom *atom )
{
   free( atom->syntax );

   switch( type( atom->flags ))
   {
      case ATOM_STRING:
         free( atom->data.string );
         break;

      case ATOM_REGEXP:
         regfree( atom->data.regexp );
         free( atom->data.regexp );
         break;

      case ATOM_TABLE:
         hash_free( atom->data.table->hash, atom->data.table->size );
         free( atom->data.table->hash );
         free( atom->data.table );
         break;

      case ATOM_DB:
#ifdef SQL
         if ( atom->data.db != NULL )
            sqlite3_close( atom->data.db );
#endif
         break;

      case ATOM_STACK:
         stack_free( atom->data.stack );
         break;

      case ATOM_CLOSURE:
      case ATOM_MACRO:
         free( atom->data.closure );
         break;

      case ATOM_ACT_RECORD:
         stack_free( atom->data.act_record );
         break;

      case ATOM_RECORD:
         free( atom->data.record );
         break;

      case ATOM_SQL:
#ifdef SQL
         if ( atom->data.sql != NULL )
            sqlite3_finalize( atom->data.sql );
#endif
         break;
   }
}

void sweep_atoms()
{
   struct atom *top;
   int i, j, old_stack_inc;

   reclaimed_atoms->free += reclaimed_atoms->used;
   reclaimed_atoms->used = 0;
   reclaimed_atoms->top = reclaimed_atoms->values;
   
   old_stack_inc = stack_inc;
   stack_inc = 65536;

   i = atom_pool_stack->used;

   while( i )
   {
      top = ( struct atom *)atom_pool_stack->values[ --i ].ptr;

      for( j = 0; j < POOL_INC; ++j, ++top )
      {
         if ( !top->id || top->id == lambda_id || top->id == macro_id || 
              top->id == quote_id || top->id == underscore_id || 
              type( top->flags ) == ATOM_INTRINSIC )
            continue;

         if ( top->id && ! isitset( top->flags ))
         {
            --atoms_allocated;

            STACK_PUSH_INT( reclaimed_ids, top->id )
            remove_id( top->syntax, top->len, top->id );

            bzero( top, sizeof( struct atom ));
            STACK_PUSH( reclaimed_atoms, top )
            continue;
         }

         unset( top->flags );
      }
   }

   for( top = atom_pool; top < atom_pool_ptr; ++top )
   {
      if ( !top->id || top->id == lambda_id || top->id == macro_id || 
           top->id == quote_id || top->id == underscore_id || 
           type( top->flags ) == ATOM_INTRINSIC )
         continue;

      if ( top->id && ! isitset( top->flags ))
      {
         --atoms_allocated;

         STACK_PUSH_INT( reclaimed_ids, top->id )
         remove_id( top->syntax, top->len, top->id );

         bzero( top, sizeof( struct atom ));
         STACK_PUSH( reclaimed_atoms, top )
         continue;
      }

      unset( top->flags );
   }

   stack_inc = old_stack_inc;
}

void mark_bookmarks()
{
   int i, j;
   struct hash_elt **ptr, *ptr2;

   for( i = 0; i < bookmark_stack->used; ++i )
   {
      if (( ptr = bookmark_stack->values[ i ].ptr ) == NULL )
         continue;

      for( j = 0; j < HASH_SIZE; ++j )
      {
         if ( *ptr == NULL )
         {
            ++ptr;
            continue;
         }

         for( ptr2 = *ptr; ptr2 != NULL; ptr2 = ptr2->next )
            set( ptr2->key->flags );

         ++ptr;
      }
   }
}

void collect_garbage()
{
#ifdef DEBUG
   fputs( "[collecting garbage: marking...", stderr );
#endif

   seen->free += seen->used;
   seen->used = 0;
   seen->top = seen->values;

   mark_bookmarks();

   mark_object( empty );
   mark_object( local_env );
   mark_stack( open_envs );

   mark_table( env, HASH_SIZE );
   mark_stack( stack );

#ifdef DEBUG
   fputs( "sweeping...", stderr );
#endif

   sweep_objects();
   sweep_atoms();

#ifdef DEBUG
   fprintf( stderr, "done: objects reclaimed: %ld, atoms reclaimed: %ld]\n",
            reclaimed_objects->used, reclaimed_atoms->used );
#endif
}

void reset_term()
{
   canon( "toplevel" );
}

int main( int argc, char **argv )
{
   atexit( reset_term );

   initialize( argc, argv );
   toplevel();

   return 0;
}
