/*
 * Copyright (c) 2001-2007 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"
#ifdef DEBUG
#include "intrinsics.c"
#endif

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 sigalrm_handler( int signo )
{
   sigalrm = 1;
}

void print_err( enum err_types err, char *func, int arg, enum err_types type)
{
   fprintf( stderr, error_messages[ err - 13 ], func, arg,
            ( type < 0 ? "" : err_strings[ type ] ));
}

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

   if ( size == 0 )
      return NULL;

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

   return ptr;
}

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

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

   return ptr;
}

#ifndef DEBUG
struct object *make_object()
{
   if ( reclaimed_objects->used )
      return stack_pop( reclaimed_objects );

   if ( object_pool_free == 0 )
   {
      stack_push( object_pool_stack, ( void *)object_pool );
#ifdef DEBUG
      fprintf( stderr, "Allocating object pool %d.\n", object_pool_stack->used );
#endif
      object_pool = ( struct object *)memory( sizeof( struct object ) * POOL_INC );
      object_pool_ptr = object_pool;
      object_pool_free = POOL_INC;
   }

   --object_pool_free;

   object_pool_ptr->data.head = object_pool_ptr->next = NULL;
   object_pool_ptr->flags = 0;

   return object_pool_ptr++;
}

struct atom *make_atom()
{
   if ( reclaimed_atoms->used )
      return ( struct atom *)stack_pop( reclaimed_atoms );

   if ( atom_pool_free == 0 )
   {
      stack_push( atom_pool_stack, ( void *)atom_pool );
#ifdef DEBUG
      fprintf( stderr, "Allocating atom pool %d.\n", atom_pool_stack->used );
#endif
      atom_pool = ( struct atom *)memory( sizeof( struct atom ) * POOL_INC );
      atom_pool_ptr = atom_pool;
      atom_pool_free = POOL_INC;
   }

   --atom_pool_free;

   atom_pool_ptr->syntax = NULL;
   atom_pool_ptr->len = 0;
   atom_pool_ptr->id = 0;
   atom_pool_ptr->flags = 0;
   atom_pool_ptr->data.hash = NULL;

   return atom_pool_ptr++;
}
#endif

struct stack *get_hash_keys( struct hash_elt **table )
{
   struct stack *stk;
   struct hash_elt *ptr;
   int i;

   stk = make_stack();

   for( i = 0; i < HASH_SIZE; ++i )
   {
      ptr = table[ i ];

      while( ptr != NULL )
      {
         stack_push( stk, ( struct object *)ptr->binding );
         ptr = ptr->next;
      }
   }

   return stk;
}

struct stack *get_hash_values( struct hash_elt **table )
{
   struct stack *stk;
   struct hash_elt *ptr;
   int i;

   stk = make_stack();

   for( i = 0; i < HASH_SIZE; ++i )
   {
      ptr = table[ i ];

      while( ptr != NULL )
      {
         stack_push( stk, ( struct object *)ptr->element );
         ptr = ptr->next;
      }
   }

   return stk;
}

void insert_elt( struct hash_elt **hash, int id, struct object *elt )
{
   int key;
   struct hash_elt *ptr = NULL, *ptr2 = NULL;

   key = ( id + HASH_SIZE ) % HASH_SIZE;

   if ( hash[ key ] == NULL )
   {
      hash[ key ] = memory( sizeof( struct hash_elt ));
      hash[ key ]->element = elt;
      hash[ key ]->next = NULL;
      hash[ key ]->binding = id;
      return;
   }

   ptr2 = hash[ key ];

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

   if ( ptr == NULL )
   {
      ptr2->next = ( struct hash_elt *)memory( sizeof( struct hash_elt ));
      ptr = ptr2->next;
      ptr->next = NULL;
   }

   ptr->element = elt;
   ptr->binding = id;
}

void *lookup_elt( struct hash_elt **hash, int id )
{
   int key;
   struct hash_elt *ptr;

   key = ( id + HASH_SIZE ) % HASH_SIZE;

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

   ptr = hash[ key ];

   do
   {
      if ( ptr->binding == id )
         return ptr->element;

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

   return NULL;
}

void remove_elt( struct hash_elt **hash, int id )
{
   int key;
   struct hash_elt *ptr, *ptr2;

   key = ( id + HASH_SIZE ) % HASH_SIZE;

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

   ptr = hash[ key ];
   ptr2 = NULL;

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

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

   if ( ptr == NULL )
      return;

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

   free( ptr );
}

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

   for( key = 0, i = len, nptr = name; i; --i )
      key += ( int )*nptr++;

   key = ( abs( key ) + HASH_SIZE ) % HASH_SIZE;

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

   ptr = syntax[ key ];
   ptr2 = NULL;

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

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

   if ( ptr == NULL )
      return;

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

   free_atom( ( struct atom *)ptr->element );
   free( ptr );
}

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

   for( key = 0, i = len, nptr = name; i; --i )
      key += ( int )*nptr++;

   key = abs( ( key + HASH_SIZE ) % HASH_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 = ( int )stack_pop( 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 ] = memory( sizeof( struct hash_elt ));
      syntax[ key ]->element = ( struct object *)atom;
      syntax[ key ]->next = NULL;
      syntax[ key ]->binding = atom->id;

      insert_atom( atom->id, atom );
      return atom;
   }

   ptr2 = syntax[ key ];

   for( ptr = ptr2; ptr != NULL; ptr = ptr->next )
   {
      atom = ( struct atom *)ptr->element;

      if ( len == atom->len )
      {
         char *ptr3 = name, *ptr4 = atom->syntax;
         int idx = len;

         while( idx-- )
            if ( *ptr3++ != *ptr4++ )
               break;

         if ( idx < 0 )
            return atom;
      }

      ptr2 = ptr;
   }

   if ( ptr == NULL )
   {
      ptr2->next = ( struct hash_elt *)memory( sizeof( struct hash_elt ));
      ptr = ptr2->next;
      ptr->next = NULL;
   }

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

   if ( reclaimed_ids->used )
      atom->id = ( int )stack_pop( 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 = ( struct object *)atom;
   ptr->binding = atom->id;
   insert_atom( atom->id, atom );

   return atom;
}

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

   ptr = hash;

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

      ptr2 = *ptr;

      do
      {
         ptr3 = ptr2->next;
         free( 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 ];

      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( void * ) * 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( stack_inc + 1 );
   *s->str = '\0';
   s->free = stack_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() )
      {
         if ( !stop )
            fprintf( stderr, "load: evaluation of expression %d in %s "
                             "failed.\n", count, filename );

         close( file );
         get_token( 0, -1 );
         return 1;
      }

      result = stack_pop( stack );
   }

   close( file );
   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;
      set( entry1->flags );
      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;
      set( entry2->flags );

      insert_binding( entry2->id, object );

      ++sp;
   }
}

void initialize( int argc, char **argv )
{
   int i, result;
   struct hash_elt **ptr;
   struct atom *atom;
   struct string *s;
   char err[ 80 ], *ptr2;
   struct sigaction sigact;
   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 );

   gc = gc_frequency = 16384;
   gc_on = 1;
   setenv( "MALLOC_OPTIONS", "<<", 1 );

   signal( SIGPIPE, SIG_DFL );
   signal( SIGCHLD, sigchld_handler );

   signal( SIGHUP, SIG_DFL );
   signal( SIGTERM, SIG_DFL );
   signal( SIGINT, SIG_DFL );
   signal( SIGQUIT, SIG_DFL );

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

   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 ));

   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 ));
      
   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" );
   }

   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 );
   }

   ptr = atoms;

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

   ptr = env;

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

   ptr = syntax;

   for( i = 0; i < HASH_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;

   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;

   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->data.record = ( void *)1;
   atom->flags = ATOM_SYMBOL;
   set( atom->flags );

   lambda_id = atom->id;
   lambda_syntax = atom->syntax;

   atom = get_id( "macro", 5, 1 );
   atom->data.record = ( void *)1;
   atom->flags = ATOM_SYMBOL;
   set( atom->flags );

   macro_id = atom->id;
   macro_syntax = atom->syntax;

   atom = get_id( "_", 1, 1 );
   atom->data.record = ( void *)1;
   atom->flags = ATOM_SYMBOL;
   set( atom->flags );

   input_stack = make_stack();
   quotes_pending = make_stack();
   arg_stack = 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" );
      exit( 1 );
   }

   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 )
      {
         load( s->str );
         stack_pop( stack );
      }

      string_free( s );
   }

   if ( argc > 1 && 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 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.
 */

void cleanup()
{
   int i;

   free_executables();
   free_history();

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

   do_child_close( "cleanup", NULL );
   display_line( NULL, NULL, NULL, 0, 0, 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 ] );

      /*
       * Closes current std descriptors.  If redirected onto processes,
       * they should exit.
       */

      close( i );
   }

   hash_free( env );
   hash_free( atoms );
   hash_free( syntax );

   free_objects();
   free_syntax();
   free_atoms();

   stack_free( stack );
   stack_free( open_envs );

   stack_free( input_stack );
   stack_free( quotes_pending );
   stack_free( arg_stack );

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

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

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

      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 );

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

#ifndef DEBUG
void stack_push( struct stack *a, void *o )
{
   if ( a->free == 0 )
   {
      a->values = realloc( a->values, sizeof( void * ) * ( 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 = o;
   --a->free;
   ++a->used;
}

struct object *stack_pop( struct stack *a )
{
   struct object *ptr;

   if ( a->used )
   {
      ptr = *a->top;
      --a->used;
      ++a->free;

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

      return ptr;
   }

   return NULL;
}

void stack_truncate( struct stack *a, int i )
{
   while( i-- )
      stack_pop( a );
}
#endif

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 + stack_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 = stack_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 + stack_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 = stack_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_chop( struct string *s )
{
   if ( s->used )
   {
      *--s->top = '\0';
      --s->used;
      ++s->free;
   }
}

void string_truncate( struct string *s )
{
   if ( s->used )
   {
      s->free += s->used;
      s->used = 0;
      *s->str = '\0';
      s->top = s->str;
   }
}

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[ 102400 ] = "", stdin_buffer[ 102400 ] ="";
   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 )
   {
      if ( old_file == 0 )
         strcpy( stdin_buffer, ptr );
      else if ( old_file > 0 )
      {
         int pos = -( strlen( ptr ));

         if ( lseek( old_file, pos, SEEK_CUR ) < 0 &&
              errno != EBADF &&
              errno != ESPIPE )
         {
            fprintf( stderr, "get_token: fatal error: lseek: %s.\n",
                     strerror( errno ));
            exit( 1 );
         }
      }

      { 
         char *tmp = NULL;

         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 ( type = TOK_END );
         }
         else if ( count == -1 )
         {
            if ( errno == EINTR || errno == EAGAIN )
               goto AGAIN;

            fprintf( stderr, "read: %s.\n", strerror( errno ));
            exit( 1 );
         }
         else
         {
            characters[ count ] = '\0';
            ptr = characters;
         }
      }

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

            ++ptr;
            continue;
         }

         if ( *ptr == '\\' )
         {
            if ( type == TOK_STRING )
            {
               if ( !( escape ^= 1 ) )
                  string_chop( token );
            }
            else
            {
               ++ptr;
               continue;
            }
         }
         else if ( *ptr != '"' )
            escape = 0;

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

            string_append( token, *ptr++ );
         }
         else 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;
         }
         else if ( *ptr == '"' )
         {
            if ( type < 0 )
            {
               type = TOK_STRING;
               string_append( token, *ptr++ );
            }
            else if ( type != TOK_STRING )
               return type;
            else
            {
               if ( escape )
                  string_chop( token );

               string_append( token, *ptr++ );

               if ( !escape )
                  return type;

               escape = 0;
            }
         }
         else 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++ );
         }
         else 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++ );
         }
         else 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++ );
         }
         else
         {
            if ( type >= 0 )
            {
               if ( type != TOK_STRING )
                  return type;
               else if ( *ptr == '\r' )
               {
                  if ( isatty( 0 ))
                     string_append( token, '\n' );
                  else
                     string_append( token, *ptr++ );
               }
               else
                  string_append( token, *ptr++ );
            }
            else
               ++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 );
   }
   else 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( quotes_pending, ( void *)quote );

      quote = -1;
   }
   else if ( type == TOK_CLOSE )
   {
      if ( --depth < 0 )
         return depth;

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

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

      if ( quote == depth )
      {
         if ( quotes_pending->used )
            quote = ( int)stack_pop( 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 ));
   }
   else
   {
      struct atom *entry;

      if ( type == TOK_FIXNUM )
         entry = toptr( atoi( token->str ));
      else
      {
         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 = make_object();
      ptr->data.atom = entry;

      if ( type == TOK_FIXNUM )
         setnumber( ptr->flags );

      stack_push( ( depth ? input_stack : stack ), ptr );

      if ( quote == -1 )
      {
         if ( quotes_pending->used )
            quote = ( int )stack_pop( 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( "%i", number( ptr->data.atom ));
      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;

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

   snprintf( buffer, sizeof( buffer ), t, closure_counter++ );
   entry = get_id( buffer, strlen( buffer ), 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 ];

   snprintf( buffer, sizeof( buffer ), "<ACT_RECORD#%d>", act_record_counter++ );
   entry = get_id( buffer, strlen( buffer ), 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( act_record, ( void *)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 ] );
               stack_push( act_record, ( void *)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( act_record, ( void *)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( act_record, ( void *)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 ] );
               stack_push( act_record, ( void *)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( act_record, ( void *)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 ] );
                  ptr3 = &( *ptr3 )->next;
               }

               stack_truncate( stack, i );
            }
         }

         stack_pop( stack );

         *ptr3 = NULL;
      }
   }

   return 0;
}

int apply_closure( char *name, struct closure *closure, struct object *args, int eval_args )
{
   struct object *obj, *ptr, *result = NULL;
   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:
   returned = 0;

   for( j = 1, ptr = current_closure->text->next; ptr != NULL; ptr = ptr->next, ++j )
   {
      stack_push( stack, ptr );

      if ( evaluate() )
      {
         if ( !stop )
            fprintf( stderr, "%s: error evaluating body expression %d.\n",
                     name, j );

         returned = 1;
         break;
      }

      result = stack_pop( stack );
   }

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

      name = tailcall_syntax;
      tailcall_syntax = NULL;

      stop = 0;
      goto TAILCALL;
   }

   if ( returned == 0 )
      stack_push( stack, result );

   local_env = stack_pop( open_envs );
   current_closure = old_closure;

   return returned;
}

struct object *lookup_local( id )
{
   struct stack *local;
   struct object *env_ptr, **ptr;

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

      for( ptr = ( struct object **)local->top;
           ptr > ( struct object **)local->values;
           ptr -= 2 )
         if ( *( int *)ptr == id )
            return ( struct object *) *--ptr;
   }

   return NULL;
}

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

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

      for( ptr = ( struct object **)local->top;
           ptr > ( struct object **)local->values;
           ptr -= 2 )
         if ( *( int *)ptr == id )
         {
            *--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_push( stack, make_atom_from_closure( closure, macro ));

   return 0;
}

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

   fputs( car->data.atom->syntax, stderr );
   if ( type( car->data.atom->flags ) == ATOM_STRING )
      fputc( '"', stderr );

   fprintf( stderr, " %s.\n", str );
}

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

   if ( gc_on && --gc <= 0 )
   {
#ifdef DEBUG
      fputs( "Collecting garbage...", stderr );
#endif
      collect_garbage();
      gc = gc_frequency;
   }

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

   if ( ( islist( (( struct object *)( *stack->top ))->flags ) && 
          (( struct object *)( *stack->top ))->data.head == NULL ) 

          ||

         ( islist( (( struct object *)( *stack->top ))->flags ) == 0 &&
           ( numberp( (( struct object *)( *stack->top ))->flags ) ||
             (( struct object *)( *stack->top ))->data.atom->id == lambda_id ||
             (( struct object * )( *stack->top ))->data.atom->id == macro_id  ||
             type( (( struct object *)( *stack->top ))->data.atom->flags ) != ATOM_SYMBOL )))
      return 0;
   
   item = stack_pop( stack );

   if ( islist( item->flags ) == 0 )
   {
      struct object *value;

      if (( value = lookup_local( item->data.atom->id )) == NULL )
      {
         value = lookup_binding( item->data.atom->id );
   
         if ( value == NULL )
         {
            fprintf( stderr, "evaluate: symbol %s not bound.\n",
                     item->data.atom->syntax );
            return 1;
         }
      }
   
      stack_push( stack, value );
   }
   else
   {
      char t, *name = NULL;
      struct object *car, *cdr;

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

      if ( islist( car->flags ) == 0 &&
           numberp( car->flags ) == 0 &&
           type( car->data.atom->flags ) == ATOM_SYMBOL )
         name = car->data.atom->syntax;

      stack_push( stack, item );
      stack_push( stack, car );

      if ( evaluate() )
         return 1;

      car = *( struct object **)stack->top;

      if ( islist( car->flags ) || numberp( car->flags ))
      {
         fprintf( stderr, "evaluate: function position did not evaluate"
                          " to an intrinsic nor a closure.\n" );
         return 1;
      }

      if ( car->data.atom->id == lambda_id )
         result = create_closure( cdr, 0 );
      else if ( car->data.atom->id == macro_id )
         result = create_closure( cdr, 1 );
      else
      {
#ifdef DEBUG
         int i;

         i = stack->used;
#endif

         t = type( car->data.atom->flags );

         switch( t )
         {
            case ATOM_INTRINSIC:
               result = car->data.atom->data.function( car->data.atom->syntax, cdr );
               break;

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

            case ATOM_MACRO:
               if (( result = apply_closure( ( name == NULL ? car->data.atom->syntax : name ),
                                             car->data.atom->data.closure,
                                             cdr,
                                             0 )) == 0 &&
                   ( result = evaluate() ))
               {
                  if ( !stop )
                     func_err( "secondary evaluation of macro failed", car );
                  return 1;
               }
               break;

            default:
               func_err( "is not an intrinsic nor a closure", car );
               return 1;
         }

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

      if ( result == 0 || next_iteration )
      {
         item = stack_pop( stack );
         stack_pop( stack );
         stack_pop( stack );
         stack_push( stack, item );
      }
   }

   return result;
}

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

   if ( isatty( 0 ) )
      printf( "--------------------------------------\n"
              "Munger %d.%d\nCopyright 2001-2007, James Bailie\nhttp://www.mammothcheese.ca/munger.html\n"
              "--------------------------------------\n\n",
              VERSION_MAJOR, VERSION_MINOR );

   for( ; ; )
   {
      int depth;

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

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

      if ( 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 );

         if ( fatal )
            exit( 1 );

         thrown = NULL;
      }
      else if ( next_iteration )
      {
         fprintf( stderr, "%s: \"continue\" used outside of loop\n", t );

         if ( fatal )
            exit( 1 );
      }
      else if ( fatal )
         exit( 1 );

      stop = next_iteration = 0;

      collect_garbage();
   }
}

void mark_record( struct object **record )
{
   int total, i;
   struct object **ptr;

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

   total = *( int *)record;

   ptr = record;
   for( i = 0; i < total; ++i )
      mark_object( *++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.hash );
            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 ] == act_record )
         return;

   stack_push( seen, act_record );

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

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

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 == 0 )
      return;

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

   stack_push( seen, stk );

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

void mark_table( struct hash_elt **ptr )
{
   struct stack *values;
   struct atom *key;
   int i;

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

   stack_push( seen, ptr );

   values = get_hash_keys( ptr );

   while( values->used )
   {
      key = lookup_atom( ( int)stack_pop( values ));
      set( key->flags );
   }

   stack_free( values );

   values = get_hash_values( ptr );

   while( values->used )
      mark_object( ( struct object *)stack_pop( values ));

   stack_free( values );
}

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;

   old_stack_inc = stack_inc;
   stack_inc = POOL_INC;

   i = object_pool_stack->used;

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

      for( j = 0; j < POOL_INC; ++j, ++top )
         if (( islist( top->flags ) && ismarked( top->flags ) == 0 ) ||
             ( numberp( top->flags ) && ismarked( top->flags ) == 0 ) ||
             ( top->flags == 0 && top->data.atom ))
         {
            bzero( top, sizeof( struct object ));
            stack_push( reclaimed_objects, top );
         }
         else
            unmark( top->flags );
   }

   for( top = object_pool; top < object_pool_ptr; ++top )
   {
      if (( islist( top->flags ) && ismarked( top->flags ) == 0 ) ||
          ( numberp( top->flags ) && ismarked( top->flags ) == 0 ) ||
          ( top->flags == 0 && top->data.atom ))
      {
         bzero( top, sizeof( struct object ));
         stack_push( reclaimed_objects, top );
      }
      else
         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.hash );
         free( atom->data.hash );
         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;

   old_stack_inc = stack_inc;
   stack_inc = POOL_INC;

   i = atom_pool_stack->used;

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

      for( j = 0; j < POOL_INC; ++j, ++top )
      {
         if ( type( top->flags ) == ATOM_INTRINSIC )
            continue;
         else if ( top->id && isitset( top->flags ) == 0 )
         {
            stack_push( reclaimed_ids, ( void *)top->id );
            remove_atom( top->id );
            remove_id( top->syntax, top->len, top->id );
            bzero( top, sizeof( struct atom ));
            stack_push( reclaimed_atoms, top );
         }
         else
            unset( top->flags );
      }
   }

   for( top = atom_pool; top < atom_pool_ptr; ++top )
   {
      if ( type( top->flags ) == ATOM_INTRINSIC )
         continue;
      else if ( top->id && isitset( top->flags ) == 0 )
      {
         stack_push( reclaimed_ids, ( void *)top->id );
         remove_atom( top->id );
         remove_id( top->syntax, top->len, top->id );
         bzero( top, sizeof( struct atom ));
         stack_push( reclaimed_atoms, top );
      }
      else
         unset( top->flags );
   }

   stack_inc = old_stack_inc;
}

void mark_bookmarks()
{
   int i;
   struct stack *keys;
   struct atom *key;

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

      keys = get_hash_keys( ( struct hash_elt **)bookmark_stack->values[ i ] );

      while( keys->used )
      {
         key = lookup_atom( ( int)stack_pop( keys ));
         set( key->flags );
      }

      stack_free( keys );
   }
}

void collect_garbage()
{
   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 );
   mark_stack( stack );

   sweep_objects();
   sweep_atoms();
}

void reset_term()
{
   if ( mode )
      canon( "" );
}

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

   initialize( argc, argv );
   toplevel();
   cleanup();

   return 0;
}