/*
 * Copyright (c) 2001-2007 James Bailie <jimmy@mammothcheese.ca>.
 * 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.
 */

#ifndef DEBUG
#include "lisp.h"
#endif

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

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

int compare_numbers( const void *a, const void *b )
{
   return *( int *)a - *( int *)b;
}

int compare_car_numbers( const void *a, const void *b )
{
   return number( ( *( struct object **)a )->data.head->data.atom ) -
          number( ( *( struct object **)b )->data.head->data.atom );
}

int compare_car_strings( const void *a, const void *b )
{
   return strncasecmp(
      ( *( struct object **)a )->data.head->data.atom->data.string->string,
      ( *( struct object **)b )->data.head->data.atom->data.string->string,
      MIN (
         ( *( struct object **)a )->data.head->data.atom->data.string->length,
         ( *( struct object **)b )->data.head->data.atom->data.string->length ) );
}

int compare_strings( const void *a, const void *b )
{
   return strncasecmp( ( *( struct lstring **)a )->string,
                       ( *( struct lstring **)b )->string,
                       MIN( ( *( struct lstring **)a )->length,
                            ( *( struct lstring **)b )->length ));
}

char *expand_tilde( char *name )
{
   struct string *s;
   char *ptr, *ptr2;

   s = make_string();
   string_assign( s, name, strlen( name ) );

   if (( s->used == 1 && s->str[ 0 ] == '~' ) ||
       ( s->used >= 2 && s->str[ 0 ] == '~' && s->str[ 1 ] == '/' ))
   {
      string_erase( s, 0 );

      ptr = getenv( "HOME" );

      if ( ptr == NULL )
         ptr = str_dup( name, strlen( name ));
      else
      {
         ptr2 = ptr;
         ptr = &ptr[ strlen( ptr ) ];

         while( ptr > ptr2 )
            string_prepend( s, *--ptr );

         ptr = str_dup( s->str, s->used );
      }
   }
   else if ( s->used > 2 && s->str[ 0 ] == '~' && isalnum( s->str[ 1 ] ))
   {
      struct string *login;
      struct passwd *passwd;

      login = make_string();
      ptr = &s->str[ 1 ];

      while( *ptr && *ptr != '/' )
         string_append( login, *ptr++ );

      passwd = getpwnam( login->str );

      if ( passwd == NULL )
         ptr = str_dup( name, strlen( name ));
      else
      {
         string_assign( login, passwd->pw_dir, strlen( passwd->pw_dir ));

         while( *ptr )
            string_append( login, *ptr++ );

         ptr = str_dup( login->str, login->used );
      }

      string_free( login );
   }
   else
      ptr = str_dup( name, strlen( name ));

   string_free( s );

   return ptr;
}

struct stack *find_possibilities( char *name )
{
   char *d, *e, *w, *ptr;
   DIR *dir, *o;
   struct dirent *dp;
   struct stack *entries;
   struct string *s, *t;
   int length, result;

   regmatch_t matches[ 4 ];

   result = regexec( &find_poss_regex, name, 4, matches, 0 );

   if ( result )
   {
      char err[ 80 ];

      free( name );
      regerror( result, &find_poss_regex, err, sizeof( err ));
      fprintf( stderr, "find_possibilities: regexec(): %s\n", err );
      return NULL;
   }

   length = matches[ 0 ].rm_eo - matches[ 0 ].rm_so;
   w = memory( length + 1 );
   bcopy( &name[ matches[ 0 ].rm_so ], w, length );
   w[ length ] = '\0';

   length = matches[ 1 ].rm_eo - matches[ 1 ].rm_so;
   d = memory( length + 1 );
   bcopy( &name[ matches[ 1 ].rm_so ], d, length );
   d[ length ] = '\0';

   length = matches[ 3 ].rm_eo - matches[ 3 ].rm_so;
   e = memory( length + 1 );
   bcopy( &name[ matches[ 3 ].rm_so ], e, length );
   e[ length ] = '\0';

   entries = make_stack();
   dir = opendir(( *d == '\0' ? "." : d ));

   t = make_string();

   if ( dir != NULL )
   {
      length = strlen( e );

      while(( dp = readdir( dir )) != NULL )
      {
         if ( dp->d_namlen >= length &&
              strncmp( e, dp->d_name, length ) == 0 )
         {
            s = make_string();
            string_assign( s, dp->d_name, dp->d_namlen );
            stack_push( entries, s );

            string_assign( t, d, strlen( d ));
            if ( t->used )
               string_append( t, '/' );

            ptr = dp->d_name;
            while( *ptr )
               string_append( t, *ptr++ );

            if (( o = opendir( t->str )) != NULL )
            {
               closedir( o );
               string_append( s, '/' );
            }
         }
      }

      closedir( dir );
   }
   else
   {
      dir = opendir( w );

      if ( dir != NULL )
      {
         while(( dp = readdir( dir )) != NULL )
         {
            s = make_string();
            string_assign( s, dp->d_name, dp->d_namlen );
            stack_push( entries, s );

            string_assign( t, w, strlen( w ));
            string_append( t, '/' );

            ptr = dp->d_name;
            while( *ptr )
               string_append( t, *ptr++ );

            if (( o = opendir( t->str )) != NULL )
            {
               closedir( o );
               string_append( s, '/' );
            }

         }

         closedir( dir );
      }
   }

   string_free( t );

   free( w );
   free( d );
   free( e );

   return entries;
}

struct stack *format_possibilities( struct stack *entries )
{
   int i, max = 1, cols, rows, total, column, target, width;
   char mask[ 10 ], *line, *ptr;
   struct stack *formatted;
   struct string *s, *t;

   for( i = 0; i < entries->used; ++i )
   {
      struct string *s;

      s = ( struct string *)entries->values[ i ];
      if ( s->used > max )
         max = s->used;
   }

   ++max;

   do_cols( "format_possibilities", NULL );
   width = number( ( *( struct object **)stack->top )->data.atom );
   stack_pop( stack );

   line = memory( width + 1 );

   cols = --width / max;
   if ( cols == 0 )
      cols = 1;

   rows = ( entries->used + cols ) / cols;
   total = rows * cols;

   snprintf( mask, sizeof( mask ), "%%-%ds ", max - 1 );

   formatted = make_stack();
   t = make_string();

   for( i = 0; i < total; ++i )
   {
      column = i % cols;
      target = column * rows + i / cols;

      if ( target < entries->used )
      {
         s = ( struct string *)entries->values[ target ];
         snprintf( line, width, mask, s->str );
         ptr = line;
         while( *ptr )
            string_append( t, *ptr++ );
      }

      if ( column == cols - 1 )
      {
         while( t->used < width )
            string_append( t, ' ' );

         stack_push( formatted, t );
         t = make_string();
      }
   }

   string_free( t );
   free( line );

   return formatted;
}

struct stack *format_possibilities_of_strings( struct stack *entries, struct stack *lengths )
{
   int i, l, max = 1, cols, rows, total, column, target, width;
   char mask[ 10 ], *line, *ptr;
   struct stack *formatted;
   char *s;
   struct string *t;

   for( i = 0; i < lengths->used; ++i )
   {
      l = ( int )lengths->values[ i ];

      if ( l > max )
         max = l;
   }

   ++max;

   do_cols( "format_possibilities", NULL );
   width = number( ( *( struct object **)stack->top )->data.atom );
   stack_pop( stack );

   line = memory( width + 1 );

   cols = --width / max;
   if ( cols == 0 )
      cols = 1;

   rows = ( entries->used + cols ) / cols;
   total = rows * cols;

   snprintf( mask, sizeof( mask ), "%%-%ds ", max - 1 );

   formatted = make_stack();
   t = make_string();

   for( i = 0; i < total; ++i )
   {
      column = i % cols;
      target = column * rows + i / cols;

      if ( target < entries->used )
      {
         s = ( char *)entries->values[ target ];
         snprintf( line, width, mask, s );

         for( ptr = line; *ptr; ++ptr )
            string_append( t, *ptr );
      }

      if ( column == cols - 1 )
      {
         while( t->used < width )
            string_append( t, ' ' );

         stack_push( formatted, t );
         t = make_string();
      }
   }

   string_free( t );
   free( line );

   return formatted;
}

struct string *find_common_prefix( struct stack *entries )
{
   struct stack *e2 = NULL;
   struct string *s, *t, *p;

   if ( entries->used == 0 )
      return NULL;

   p = make_string();

   if ( entries->used == 1 )
   {
      s = ( struct string *)entries->values[ 0 ];
      string_assign( p, s->str, s->used );
      return p;
   }

   {
      int i, j, k, min = 10000;

      for( i = 0; i < 2; ++i )
      {
         for( j = 0; j < entries->used; ++j )
         {
            s = ( struct string *)entries->values[ j ];
            if ( s->used < min )
               min = s->used;
         }

         s = ( struct string *)entries->values[ 0 ];

         for( j = 0; j < min; ++j )
         {
            for( k = 1; k < entries->used; ++k )
            {
               t = ( struct string *)entries->values[ k ];

               if ( s->str[ j ] != t->str[ j ] )
                  goto NEXT;
            }

            string_append( p, s->str[ j ] );
         }

      NEXT:
         if ( p->used || i == 1 )
            break;

         e2 = make_stack();

         for( j = 0; j < entries->used; ++j )
         {
            s = ( struct string *)entries->values[ j ];
            if ( strcmp( s->str, "../" ) && strcmp( s->str, "./" ))
               stack_push( e2, s );
         }

         if ( e2->used == 1 )
         {
            s = ( struct string *)e2->values[ 0 ];
            string_assign( p, s->str, s->used );
            break;
         }

         min = 10000;
         entries = e2;
      }
   }

   if ( e2 != NULL )
      stack_free( e2 );

   return p;
}

struct string *find_common_prefix_of_strings( struct stack *entries, struct stack *lengths )
{
   char *s, *t;
   struct string *p;
   int l;

   if ( entries->used == 0 )
      return NULL;

   p = make_string();

   if ( entries->used == 1 )
   {
      string_assign( p, ( char *)entries->values[ 0 ], ( int )lengths->values[ 0 ] );
      return p;
   }

   {
      int j, k, min = MAXNAMLEN;

      for( j = 0; j < entries->used; ++j )
      {
         l = ( int )lengths->values[ j ];

         if ( l < min )
            min = l;
      }

      s = ( char *)entries->values[ 0 ];

      for( j = 0; j < min; ++j )
      {
         for( k = 1; k < entries->used; ++k )
         {
            t = ( char *)entries->values[ k ];

            if ( s[ j ] != t[ j ] )
               goto NEXT;
         }

         string_append( p, s[ j ] );
      }
   }

NEXT:
   return p;
}

struct string *merge( char *first, char *second )
{
   regmatch_t matches[ 1 ];
   int result, length;
   struct string *merged;
   char *ptr;

   result = regexec( &merge_regex, first, 1, matches, 0 );

   if ( result && result != REG_NOMATCH )
   {
      char err[ 80 ];

      regerror( result, &merge_regex, err, sizeof( err ));
      fprintf( stderr, "merge: regexec(): %s\n.", err );
      return NULL;
   }

   merged = make_string( );

   if ( result != REG_NOMATCH )
   {
      int i;

      length = strlen( first ) - ( matches[ 0 ].rm_eo - matches[ 0 ].rm_so );

      for( i = 0; i < length; ++i )
         string_append( merged, first[ i ] );
   }
   else
      string_assign( merged, first, strlen( first ));

   ptr = second;
   while( *ptr )
      string_append( merged, *ptr++ );

   return merged;
}

void *complete( char *name, int display, int fd, int recurse )
{
   struct stack *p, *f;
   struct string *s, *completion = NULL;
   int i;
   char *source;

   totally_complete = 0;
   p = f = NULL;
   source = expand_tilde( name );

AGAIN:
   p = find_possibilities( source );

   if ( p == NULL )
   {
      if ( display )
         return str_dup( "", 0 );

      completion = make_string();
   }
   else if ( p->used == 1 )
   {
      s = ( struct string *)p->values[ 0 ];

      completion = merge( source, s->str );

      if ( *( completion->top - 1) == '/' )
      {
         stack_free( p );
         string_free( s );
         free( source );
         source = str_dup( completion->str, completion->used );
         string_free( completion );

         if ( recurse )
            goto AGAIN;
         else
            return source;
      }

      totally_complete = 1;
   }
   else if ( p->used )
   {
      s = find_common_prefix( p );

      if ( s->used )
      {
         completion = merge( source, s->str );
         string_free( s );

         if ( *( completion->top - 1 ) == '/' )
         {
            for( i = 0; i < p->used; ++i )
               string_free( ( struct string *)p->values[ i ] );

            stack_free( p );
            free( source );
            source = str_dup( completion->str, completion->used );
            string_free( completion );

            if ( recurse )
               goto AGAIN;
            else
               return source;
         }
      }
      else
      {
         completion = make_string();
         string_assign( completion, source, strlen( source ));

         if ( completion->used && *( completion->top - 1 ) != '/' )
            string_append( completion, '/' );
      }

      f = format_possibilities( p );

      if ( display )
      {
         if ( f->used )
            fwrite( "\r\n", 2, 1, stdout );

         while( f->used )
         {
            s = ( struct string *)stack_pop( f );

            fwrite( s->str, s->used, 1, stdout );
            fwrite( "\r\n", 2, 1, stdout );

            string_free( s );
         }

         stack_free( f );
      }
   }

   if ( p != NULL && p->used )
      for( i = 0; i < p->used; ++i )
      {
         s = ( struct string *)p->values[ i ];
         string_free( s );
      }

   if ( p != NULL )
      stack_free( p );

   if ( completion == NULL )
   {
      completion = make_string();
      string_assign( completion, source, strlen( source ));
   }

   free( source );

   if ( !display )
   {
      if ( f == NULL )
         f = make_stack();

      stack_push( f, completion );
      return f;
   }

   name = str_dup( completion->str, completion->used );
   string_free( completion );

   return name;
}

int check_args( char *syntax, struct object *args )
{
   struct object *ptr, *item;
   int total, idx, count, type, result, limit, t, l;

   total = ( int)stack_pop( arg_stack );

   if ( total == 0 )
   {
      if ( args == NULL )
         return 0;

      print_err( ERR_ARGS, syntax, 0, -1 );
      return 1;
   }
   else if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      stack_truncate( arg_stack, total );
      return 1;
   }

   idx = arg_stack->used - total;
   limit = arg_stack->used;
   ptr = args;
   count = 0;

   while( ptr != NULL )
   {
      ++count;

      if ( idx == limit )
         break;

      type = ( int)arg_stack->values[ idx++ ];

      stack_push( stack, ptr );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, count, -1 );

         stack_truncate( arg_stack, total );
         return 1;
      }

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

      l = islist( item->flags );

      if ( numberp( item->flags ) )
         t = ATOM_FIXNUM;
      else
         t = ( l ? -1 : type( item->data.atom->flags ));

      switch( type )
      {
         case ERR_SYMBOL:
            if ( l || t != ATOM_SYMBOL )
            {
               print_err( ERR_ARG_TYPE, syntax, count, ERR_SYMBOL );
               stack_truncate( arg_stack, total );
               return 1;
            }
            break;

         case ERR_STRING:
            if ( l || t != ATOM_STRING )
            {
               print_err( ERR_ARG_TYPE, syntax, count, ERR_STRING );
               stack_truncate( arg_stack, total );
               return 1;
            }
            break;

         case ERR_FIXNUM:
            if ( l || numberp( item->flags ) == 0 )
            {
               print_err( ERR_ARG_TYPE, syntax, count, ERR_FIXNUM );
               stack_truncate( arg_stack, total );
               return 1;
            }
            break;

         case ERR_REGEXP:
            if ( l || t != ATOM_REGEXP )
            {
               print_err( ERR_ARG_TYPE, syntax, count, ERR_REGEXP );
               stack_truncate( arg_stack, total );
               return 1;
            }
            break;

         case ERR_TABLE:
            if ( l || t != ATOM_TABLE )
            {
               print_err( ERR_ARG_TYPE, syntax, count, ERR_TABLE );
               stack_truncate( arg_stack, total );
               return 1;
            }
            break;

         case ERR_STACK:
            if ( l || t != ATOM_STACK )
            {
               print_err( ERR_ARG_TYPE, syntax, count, ERR_STACK );
               stack_truncate( arg_stack, total );
               return 1;
            }
            break;

         case ERR_ATOM:
            if ( l )
            {
               print_err( ERR_ARG_TYPE, syntax, count, ERR_ATOM );
               stack_truncate( arg_stack, total );
               return 1;
            }
            break;

         case ERR_LIST:
            if ( l == 0 )
            {
               print_err( ERR_ARG_TYPE, syntax, count, ERR_LIST );
               stack_truncate( arg_stack, total );
               return 1;
            }
            break;

         case ERR_CLOSURE:
            if ( l || ( t != ATOM_CLOSURE && t != ATOM_MACRO ))
            {
               print_err( ERR_ARG_TYPE, syntax, count, ERR_CLOSURE );
               stack_truncate( arg_stack, total );
               return 1;
            }
            break;

         case ERR_RECORD:
            if ( l || t != ATOM_RECORD )
            {
               print_err( ERR_ARG_TYPE, syntax, count, ERR_RECORD );
               stack_truncate( arg_stack, total );
               return 1;
            }
            break;
      }

      ptr = ptr->next;
   }

   if ( ptr != NULL )
   {
      print_err( ERR_MORE_ARGS, syntax, --count, -1 );
      result = 1;
   }
   else if ( idx < limit )
   {
      print_err( ERR_MISSING_ARG, syntax, ++count, -1 );
      result = 1;
   }
   else
      result = 0;

   stack_truncate( arg_stack, total );

   return result;
}

struct object *make_atom_from_record( struct object **record )
{
   struct object *obj;
   struct atom *entry;
   char buffer[ 128 ];

   snprintf( buffer, sizeof( buffer ), "<RECORD#%d>", record_counter++ );
   entry = get_id( buffer, strlen( buffer ), 1 );

   if ( entry->flags == 0 )
   {
      entry->flags = ATOM_RECORD;
      entry->data.record = record;
   }

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

   return obj;
}

struct object *make_atom_from_stack( struct stack *stk )
{
   struct object *object;
   struct atom *entry;
   char buffer[ 64 ];

   snprintf( buffer, sizeof( buffer ), "<STACK#%d>", stack_counter++ );

   entry = get_id( buffer, strlen( buffer ), 1 );
   entry->flags = ATOM_STACK;
   entry->data.stack = stk;

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

   return object;
}

struct object *make_atom_from_number( int i )
{
   struct object *object;

   object = make_object();
   setnumber( object->flags );
   object->data.atom = toptr( i );

   return object;
}

#ifdef SQL
struct object *make_atom_from_db( sqlite3 *db )
{
   struct atom *entry;
   struct object *obj;
   char buffer[ 64 ];

   snprintf( buffer, sizeof( buffer ), "<DB#%d>", db_counter++ );

   entry = get_id( buffer, strlen( buffer ), 1 );
   entry->flags = ATOM_DB;
   entry->data.db = db;

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

   return obj;
}

int do_sqlitep( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;

      car = stack_pop( stack );

      if ( islist( car->flags ) == 0 &&
           numberp( car->flags ) == 0 &&
           type( car->data.atom->flags ) == ATOM_DB )
         stack_push( stack, make_atom_from_number( 1 ));
      else
         stack_push( stack, make_atom_from_number( 0 ));
   }

   return 0;
}
#endif

struct object *make_atom_from_string( char *s, int len )
{
   struct atom *entry;
   struct object *object;
   struct string *new;

   new = make_string();

   if ( len == -1 )
      len = strlen( s );

   string_assign( new, s, len );
   string_prepend( new, '"' );

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

   if ( entry->flags == 0 )
   {
      entry->flags = ATOM_STRING;
      entry->data.string = memory( sizeof( struct lstring ));
      entry->data.string->length = len;
      entry->data.string->string = &entry->syntax[ 1 ];
   }

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

   return object;
}

struct object *make_atom_from_symbol( char *symbol )
{
   struct atom *entry;
   struct object *object;

   entry = get_id( symbol, strlen( symbol ), 1 );

   if ( entry->flags == 0 )
   {
      entry->flags = ATOM_SYMBOL;
      entry->data.record = NULL;
   }

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

   return object;
}

struct object *make_atom_from_regexp( regex_t *rx )
{
   struct atom *entry;
   struct object *object;
   char buffer[ 128 ];

   snprintf( buffer, sizeof( buffer ), "<REGEX#%d>", rx_counter++ );
   entry = get_id( buffer, strlen( buffer ), 1 );

   entry->flags = ATOM_REGEXP;
   entry->data.regexp = rx;

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

   return object;
}

struct object *duplicate_object( struct object *ptr )
{
   struct object *ptr2, *ptr3, *top;

   if ( ptr == NULL )
      return NULL;

   if ( islist( ptr->flags ) == 0 )
   {
      ptr2 = make_object();
      *ptr2 = *ptr;

      return ptr2;
   }

   top = make_object();
   setlist( top->flags );
   top->data.head = top->next = NULL;

   ptr2 = NULL;
   ptr = ptr->data.head;

   while( ptr != NULL )
   {
      ptr3 = ptr2;

      if ( islist( ptr->flags ) == 0 )
      {
         ptr2 = make_object();
         *ptr2 = *ptr;
      }
      else
         ptr2 = duplicate_object( ptr );

      if ( top->data.head == NULL )
         top->data.head = ptr2;
      else
         ptr3->next = ptr2;

      ptr = ptr->next;
   }

   return top;
}

int do_lines( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct winsize winsize;

      if ( ioctl( 1, TIOCGWINSZ, &winsize ) < 0 )
      {
         fprintf( stderr, "%s: %s.\n", syntax, strerror( errno ));
         return 1;
      }

      stack_push( stack, make_atom_from_number( winsize.ws_row ));
   }

   return 0;
}

int do_cols( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct winsize winsize;

      if ( ioctl( 1, TIOCGWINSZ, &winsize ) < 0 )
      {
         fprintf( stderr, "%s: %s.\n", syntax, strerror( errno ));
         return 1;
      }

      stack_push( stack, make_atom_from_number( winsize.ws_col ));
   }

   return 0;
}

int do_progn( char *syntax, struct object *args )
{
   struct object *ptr, *result = NULL;
   int i;

   if ( args == NULL )
   {
      fprintf( stderr, "%s: missing body.\n", syntax );
      return 1;
   }

   for( i = 1, ptr = args; ptr != NULL; ptr = ptr->next, ++i )
   {
      stack_push( stack, ptr );

      if ( evaluate() )
      {
         if ( !stop )
            fprintf( stderr, "%s: error evaluating body expression %d.\n",
                     syntax, i );
         return 1;
      }

      result = stack_pop( stack );
   }

   stack_push( stack, result );

   return 0;
}

int do_cons( char *syntax, struct object *args )
{
   struct object *car1, *car2, *new, *new2;

   stack_push( arg_stack, ( void *)-1);
   stack_push( arg_stack, ( void *)ERR_LIST );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   new2 = duplicate_object( car1 );
   new2->next = car2->data.head;

   new = make_object();
   setlist( new->flags );
   new->data.head = new2;

   stack_push( stack, new );

   return 0;
}

int do_quote( char *syntax, struct object *args )
{
   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   stack_push( stack, args );

   return 0;
}

int do_car( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)ERR_LIST );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   if ( car->data.head == NULL )
   {
      fprintf( stderr, "%s: argument is empty list.\n", syntax );
      return 1;
   }
   else
      stack_push( stack, car->data.head );

   return 0;
}

int do_cdr( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)ERR_LIST );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   if ( car->data.head == NULL )
   {
      fprintf( stderr, "%s: argument is empty list.\n", syntax );
      return 1;
   }
   else
   {
      stack_push( stack, make_object() );
      setlist( ( *( struct object **)stack->top )->flags );
      ( *( struct object **)stack->top )->data.head = car->data.head->next;
   }

   return 0;
}

int do_eq( char *syntax, struct object *args )
{
   struct object *car1, *car2;
   int i;

   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   i = 0;

   if ( islist( car1->flags ) == 0 &&
        islist( car2->flags ) == 0 )
   {
      i = ( car1->data.atom == car2->data.atom );
   }
   else if ( islist( car1->flags ) == 1 &&
             islist( car2->flags ) == 1 )
   {
      i = (( car1->data.head == NULL && car2->data.head == NULL ) || car1 == car2 );
   }

   stack_push( stack, make_atom_from_number( i ));

   return 0;
}

int do_atomp( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   stack_push( stack, ( islist( car->flags ) ? make_atom_from_number( 0 ) :
                                               make_atom_from_number( 1 )));

   return 0;
}

int do_append( char *syntax, struct object *args )
{
   struct object *car1, *car2, *ptr;

   stack_push( arg_stack, ( void *)ERR_LIST );
   stack_push( arg_stack, ( void *)ERR_LIST );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   car2 = duplicate_object( car2 );

   ptr = car1->data.head;

   if ( ptr == NULL )
   {
      stack_push( stack, car2 );
      return 0;
   }

   car1 = duplicate_object( car1 );
   ptr = car1->data.head;

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

   ptr->next = car2->data.head;

   stack_push( stack, car1 );

   return 0;
}

int do_set( char *syntax, struct object *args )
{
   struct object *car1, *car2;

   stack_push( arg_stack, ( void *)ERR_SYMBOL );
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   if ( set_local( car1->data.atom->id, car2 ))
      insert_binding( car1->data.atom->id, car2 );

   stack_push( stack, car2 );

   return 0;
}

int do_eval( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, -1 );
      return 1;
   }

   return 0;
}

int do_if( char *syntax, struct object *args )
{
   struct object *result;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 1, -1 );
      return 1;
   }

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

   stack_push( stack, args );

   if ( evaluate() )
   {
      if ( !stop )
         fprintf( stderr, "%s: evaluation of test expression failed.\n",
                  syntax );
      return 1;
   }

   result = stack_pop( stack );

   if (( islist( result->flags ) == 1 && result->data.head == NULL ) ||
         ( islist( result->flags ) == 0 && ( result->data.atom == NULL ||
                                             result->data.atom == empty->data.atom )))
   {
      if ( args->next->next == NULL )
      {
         stack_push( stack, result );
         return 0;
      }

      if ( do_progn( syntax, args->next->next ) )
      {
         if ( !stop )
            fprintf( stderr,
                     "%s: evaluation of alternative expression(s) failed.\n",
                     syntax );
         return 1;
      }

      return 0;
   }

   stack_push( stack, args->next );

   if ( evaluate() )
   {
      if ( !stop )
         fprintf( stderr, "%s: evaluation of consequent expression failed.\n",
                  syntax );
      return 1;
   }

   return 0;
}

int do_and( char *syntax, struct object *args )
{
   struct object *ptr, *result = NULL;
   int i;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   i = 1;

   for( ptr = args; ptr != NULL; ptr = ptr->next )
   {
      stack_push( stack, ptr );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, i, 0 );
         return 1;
      }

      result = stack_pop( stack );

      if (( islist( result->flags ) == 1 && result->data.head == NULL ) ||
            ( islist( result->flags ) == 0 && ( result->data.atom == NULL ||
                                                result->data.atom == empty->data.atom )))
          break;

      ++i;
   }

   stack_push( stack, result );

   return 0;
}

int do_or( char *syntax, struct object *args )
{
   struct object *ptr, *result = NULL;
   int i;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   for( i = 1, ptr = args; ptr != NULL; ptr = ptr->next, ++i )
   {
      stack_push( stack, ptr );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, i, -1 );
         return 1;
      }

      result = stack_pop( stack );

      if (( islist( result->flags ) == 1 && result->data.head == NULL ) ||
            ( islist( result->flags ) == 0 && ( result->data.atom == NULL ||
                                                result->data.atom == empty->data.atom )))
         continue;

      break;
   }

   stack_push( stack, result );

   return 0;
}

int do_list( char *syntax, struct object *args )
{
   struct object *ptr, **new, *result;
   int i, j;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   for( i = 0, ptr = args; ptr != NULL; ptr = ptr->next, ++i )
   {
      stack_push( stack, ptr );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, i + 1, -1 );
         return 1;
      }
   }

   result = make_object();
   setlist( result->flags );
   new = &result->data.head;

   for( j = i; j; --j )
   {
      *new = duplicate_object( ( struct object *)stack->values[ stack->used - j ] );
      ( *new )->next = NULL;
      new = &( *new )->next;
   }

   stack_truncate( stack, i );
   stack_push( stack, result );

   return 0;
}

int do_not( char *syntax, struct object *args )
{
   struct object *result;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   if ( args->next )
   {
      print_err( ERR_MORE_ARGS, syntax, 1, -1 );
      return 1;
   }

   stack_push( stack, args );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, -1 );
      return 1;
   }

   result = stack_pop( stack );

   if (( islist( result->flags ) == 1 && result->data.head == NULL ) ||
         ( islist( result->flags ) == 0 && ( result->data.atom == NULL ||
                                             result->data.atom == empty->data.atom )))
      stack_push( stack, make_atom_from_number( 1 ));
   else
      stack_push( stack, make_atom_from_number( 0 ));

   return 0;
}

void do_print_objects_strings_unquoted( struct object *ptr, int recursive, int descr )
{
   while( ptr != NULL )
   {
      if ( islist( ptr->flags ) == 1 )
      {
         fputc( '(', ( descr ? stderr : stdout ));
         do_print_objects_strings_unquoted( ptr->data.head, 1, descr );
         fputc( ')', ( descr ? stderr : stdout ));
      }
      else
      {
         if ( numberp( ptr->flags ) )
            fprintf( ( descr ? stderr : stdout ), "%i", number( ptr->data.atom ));
         else
         {
            char *str;
            int len;

            if ( recursive == 0 && type( ptr->data.atom->flags ) == ATOM_STRING )
            {
               str = ptr->data.atom->data.string->string;
               len = ptr->data.atom->data.string->length;
            }
            else
            {
               str = ptr->data.atom->syntax;
               len = ptr->data.atom->len;
            }

            fwrite( str, len, 1, ( descr ? stderr : stdout ));

            if ( recursive && type( ptr->data.atom->flags ) == ATOM_STRING )
               fputc( '"', ( descr ? stderr : stdout ));
         }
      }

      if ( recursive == 0 )
         break;

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

int do_print( char *syntax, struct object *args )
{
   struct object *ptr;
   int i;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   for( i = 1, ptr = args; ptr != NULL; ptr = ptr->next, ++i )
   {
      stack_push( stack, ptr );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, i, -1 );
         return 1;
      }

      do_print_objects_strings_unquoted( stack_pop( stack ), 0, 0 );
   }

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_println( char *syntax, struct object *args )
{
   struct object *ptr;
   int i;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   for( i = 1, ptr = args; ptr != NULL; ptr = ptr->next, ++i )
   {
      stack_push( stack, ptr );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, i, -1 );
         return 1;
      }

      do_print_objects_strings_unquoted( stack_pop( stack ), 0, 0 );
   }

   fputc( '\n', stdout );
   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_newline( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   fputc( '\n', stdout );
   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_load( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   return load( car->data.atom->data.string->string );
}

void nocanon( char *syntax )
{
   if ( mode == 0 )
      return;

   if ( isatty( 0 ) == 0 )
      return;

   if ( isatty( 0 ) )
   {
      struct termios termios;

      cfmakeraw( &termios );
      termios.c_cc[ VMIN ] = 1;
      termios.c_cc[ VTIME ] = 0;

   AGAIN:
      if ( tcsetattr( 0, TCSANOW, &termios ) < 0 )
      {
         if ( errno == EAGAIN || errno == EINTR )
            goto AGAIN;

         fprintf( stderr, "%s: tcsetattr: %s.\n", syntax, strerror( errno ));
         return;
      }

      mode = 0;
   }

   return;
}

void blocking_fd( int fd )
{
   int flags;

   /*
    * I stole this from /usr/src/bin/sh/input.c
    *
    * When running msh.munger example program as my shell, I would launch X,
    * then exit, and descriptor 0 would be in non-blocking mode, causing
    * read() to fail with errno set to EAGAIN.  So I made "canon" check for
    * this and correct.  /bin/sh does the same thing.
    */

   flags = fcntl( fd, F_GETFL, 0 );

   if ( flags >= 0 && ( flags & O_NONBLOCK ))
   {
      flags &= ~O_NONBLOCK;
      fcntl( fd, F_SETFL, flags );
   }
}

void canon( char *syntax )
{
   if ( mode )
      return;

   if ( isatty( 0 ) < 0 )
      return;

AGAIN:
   if ( tcsetattr( 0, TCSANOW, &canon_termios ) < 0 )
   {
      if ( errno == EAGAIN || errno == EINTR )
         goto AGAIN;

      fprintf( stderr, "%s: tcsetattr: %s.\n", syntax, strerror( errno ));
      return;
   }

   blocking_fd( 0 );
   mode = 1;

   return;
}

int do_complete( char *syntax, struct object *args )
{
   struct object *car, **ptr, *result;
   struct stack *results;
   struct string *str;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   results = ( struct stack *)complete( car->data.atom->data.string->string, 0, 1, 1 );

   result = make_object();
   setlist( result->flags );
   ptr = &result->data.head;

   while( results->used )
   {
      str = ( struct string *)stack_pop( results );
      *ptr = make_atom_from_string( str->str, str->used );
      string_free( str );

      ptr = &( *ptr )->next;
   }

   stack_free( results );
   stack_push( stack, result );

   return 0;
}

int getline_from_file( char *syntax, int reset )
{
   static char buffer[ 102400 ] = "", *ptr = buffer;
   int result;
   static int len = 0;
   struct string *s;

   switch( reset )
   {
      case 1:
         stack_push( input_buffer_stack, str_dup( ptr, len ));
         stack_push( input_buffer_stack, ( void *)len );

         buffer[ 0 ] = '\0';
         len = 0;
         ptr = buffer;
         return 0;

      case 2:
         if ( input_buffer_stack->used )
         {
            len = ( int )stack_pop( input_buffer_stack );
            ptr = ( char * )stack_pop( input_buffer_stack );
            bcopy( ptr, buffer, len );
            free( ptr );
            ptr = buffer;
         }
         else
         {
            buffer[ 0 ] = '\0';
            ptr = buffer;
            len = 0;
         }

         return 0;
   }

   s = make_string();
   string_append( s, '"' );

   for( ; ; )
   {
      if ( len == 0 )
      {
         if (( result = read( 0, buffer, sizeof( buffer ) - 1 )) < 0 )
         {
            if ( errno == EINTR )
               continue;

            fprintf( stderr, "%s: read: %s.\n", syntax, strerror( errno ));
            string_free( s );
            return 1;
         }
         else if ( result == 0 )
         {
            len = 0;

            if ( s->used > 1 )
            {
               stack_push( stack, make_atom_directly_from_string( s->str, s->used ));
               free( s );
            }
            else
            {
               stack_push( stack, make_atom_from_number( 0 ));
               string_free( s );
            }

            return 0;
         }

         buffer[ result ] = '\0';
         ptr = buffer;
         len = result;
      }

      while( len )
      {
         string_append( s, *ptr );
         --len;

         if ( *ptr++ == 10 )
            goto NEXT;
      }
   }

NEXT:
   stack_push( stack, make_atom_directly_from_string( s->str, s->used ));
   free( s );

   return 0;
}

int do_rescan_path( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   free_executables();

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

void make_executables()
{
   DIR *dir;
   struct dirent *dp;
   int i, j;
   char *ptr, *ptr2;
   struct stack *stk;

   if ( path == NULL && (( path = getenv( "PATH" )) == NULL ))
      return;

   stk = make_stack();

   ptr2 = path = str_dup( path, strlen( path ));

   while(( ptr = strsep( &ptr2, ":" )) != NULL )
      if ( *ptr != '\0')
         stack_push( stk, ptr );

   if ( stk->used == 0 )
   {
      free( path );
      path = NULL;
      stack_free( stk );
      return;
   }

   executables = make_stack();

   for( i = 0; i < stk->used; ++i )
   {
      if (( dir = opendir( ( char *)stk->values[ i ] )) == NULL )
      {
         if ( errno == ENOENT )
            continue;

         fprintf( stderr, "make_executables(): opendir: %s.\n", strerror( errno ));

         free( path );
         path = NULL;
         stack_free( stk );
         return;
      }

      readdir( dir );
      readdir( dir );

      while(( dp = readdir( dir )) != NULL )
      {
         stack_push( executables, str_dup( dp->d_name, dp->d_namlen ));
         stack_push( executables, ( void *)(( int )dp->d_namlen ));
         stack_push( executables, ( char *)stk->values[ i ] );
      }

      closedir( dir );
   }

   while( stk->used )
      stack_pop( stk );

   while( executables->used )
   {
      ptr2 = ( char *)stack_pop( executables );
      j = ( int )stack_pop( executables );
      ptr = ( char *)stack_pop( executables );

      for( i = 0; i < stk->used; i += 3 )
         if ( !strcmp( stk->values[ i ], ptr ))
         {
            free( ptr );
            ptr = NULL;
            break;
         }

      if ( ptr != NULL )
      {      
         stack_push( stk, ptr );
         stack_push( stk, ( void *)j );
         stack_push( stk, ptr2 );
      }
   }

   stack_free( executables );
   executables = stk;

   /*
    * path gets freed in free_executables().
    */
}

int do_command_lookup( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      char *str, *ptr;
      struct string *s;
      int i;

      car = stack_pop( stack );
      str = car->data.atom->data.string->string;

      if ( executables == NULL )
         make_executables();

      for( i = 0; i < executables->used; i += 3 )
         if ( strcmp( str, ( char *)executables->values[ i ] ) == 0 )
            break;

      if ( i == executables->used )
         stack_push( stack, empty );
      else
      {
         s = make_string();
         string_append( s, '"' );

         for( ptr = ( char *)executables->values[ i + 2 ]; *ptr; ++ptr )
            string_append( s, *ptr );

         if ( *s->top != '/' )
            string_append( s, '/' );

         for( ptr = str; *ptr; ++ptr )
            string_append( s, *ptr );

         stack_push( stack, make_atom_directly_from_string( s->str, s->used ));
         free( s );
      }
   }

   return 0;
}

struct string *complete_from_path( char *syntax, char *input, int len, int fd )
{
   int i, j;
   char *ptr;
   struct stack *stk, *stk2, *f;
   struct string *s, *result;

   stk = make_stack();
   stk2 = make_stack();

   if ( executables == NULL )
      make_executables();

   for( i = 0; i < executables->used; i += 3 )
   {
      ptr = ( char *)executables->values[ i ];

      if ( !len )
      {
         stack_push( stk, ptr );
         stack_push( stk2, executables->values[ i + 1 ] );
      }
      else
      {
         if (( j = ( int )executables->values[ i + 1 ] ) < len )
            continue;

         if ( strncmp( ptr, input, len ) == 0 )
         {
            stack_push( stk, ptr );
            stack_push( stk2, ( void *)j );
         }
      }
   }

   f = NULL;

   switch( stk->used )
   {
      case 0:
         result = make_string();
         string_assign( result, input, len );
         break;

      case 1:
         result = make_string();
         string_assign( result, ( char *)stk->values[ 0 ], ( int )stk2->values[ 0 ] );
         string_append( result, ' ' );
         break;

      default:
         result = find_common_prefix_of_strings( stk, stk2 );
         f = format_possibilities_of_strings( stk, stk2 );

         if ( f->used )
         {
            fwrite( "\r\n", 2, 1, stdout );

            while( f->used )
            {
               s = ( struct string *)stack_pop( f );
               fwrite( s->str, s->used, 1, stdout );
               fwrite( "\r\n", 2, 1, stdout );
               string_free( s );
            }
         }

         stack_free( f );
   }

   stack_free( stk2 );
   stack_free( stk );

   return result;
}

void add_history( struct string *s )
{
   int i;

   string_chop( s );

   if ( s->used == 0 )
      return;

   for( i = 0; i < history->used; ++i )
      if ( strcmp( ( char *)history->values[ i ], s->str ) == 0 )
         break;

   if ( i == history->used - 1 )
      return;

   if ( history->used && i < history->used )
   {
      char *tmp;

      tmp = history->values[ i ];

      for( ; i < history->used - 1; ++i )
         history->values[ i ] = history->values[ i + 1 ];

      history->values[ i ] = tmp;
      return;
   }

   if ( history->used == 500 )
   {
      for( i = 0; i < history->used - 1; ++i )
         history->values[ i ] = history->values[ i + 1 ];

      history->values[ i ] = str_dup( s->str, s->used );
   }
   else
      stack_push( history, str_dup( s->str, s->used ));
}

char *back_history()
{
   if ( history->used == 0 || history_ptr == 0 )
      return NULL;

   return ( char *)history->values[ --history_ptr ];
}

char *forw_history()
{
   if ( history->used == 0 || history_ptr == history->used )
      return NULL;

   ++history_ptr;

   if ( history_ptr == history->used )
      return NULL;
   else
      return ( char*)history->values[ history_ptr ];
}

char *search_history( char *str, int dir )
{
   char *ptr;
   int old_history_ptr;
   char *( *func )();

   old_history_ptr = history_ptr;

   func = ( dir ? forw_history : back_history );

   for( ptr = func(); ptr != NULL; ptr = func() )
      if ( strstr( ptr, str ) != NULL )
         break;

   if ( ptr == NULL )
      history_ptr = old_history_ptr;

   return ptr;
}

#define forw_search_history( s ) search_history( s, 1 )
#define back_search_history( s ) search_history( s, 0 )

void display_line( struct string *s, struct string *after,
                   char *prompt, int plen, int tabstop,
                   struct stack *offsets )
{
   int len, idx, space;
   static struct string *working = NULL;
   char *ptr;

   if ( s == NULL )
   {
      if ( working != NULL )
         string_free( working );

      working = NULL;
      return;
   }

   if ( working == NULL )
      working = make_string();
   else
      string_truncate( working );

   idx = 0;

   for( ptr = s->str; *ptr; ++ptr )
      if ( *ptr != '\t' )
         string_append( working, *ptr );
      else
      {
         len = ( int )offsets->values[ idx++ ];
         while( len-- )
            string_append( working, ' ' );
      }

   if ( LINES <= 0 || COLS <= 0 )
      return;

   putp( tgoto( cm, 0, LINES - 1 ));
   putp( ce );

   len = working->used;
   idx = 0;
   space = ( COLS - 1 ) - plen;

   if ( space > 0 )
      while( len >= space )
      {
         len -= space;
         idx += space;
         space = ( COLS - 1 );
      }
   
   if ( idx == 0 && plen )
      fwrite( prompt, plen, 1, stdout );

   if ( len )
      fwrite( working->str + idx, len, 1, stdout );

   if ( ! idx )
      len += plen;

   idx = after->used;
   space = ( COLS - 1 ) - len;

   if ( space > 0 )
      while( --idx >= 0 && space-- )
         fputc( after->str[ idx ], stdout );
   
   putp( tgoto( cm, len, LINES - 1 ));
   fflush( stdout );
}

int do_getline( char *syntax, struct object *args )
{
   struct object *car1 = NULL, *car2 = NULL;

   if ( args != NULL )
   {
      if ( args->next != NULL && args->next->next != NULL )
      {
         print_err( ERR_MORE_ARGS, syntax, 2, -1 );
         return 1;
      }

      stack_push( stack, args );

      if ( evaluate())
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 1, -1 );
         return 1;
      }

      car1 = stack_pop( stack );

      if ( islist( car1->flags ) == 1 ||
           numberp( car1->flags ) ||
           type( car1->data.atom->flags ) != ATOM_STRING )
      {
         print_err( ERR_ARG_TYPE, syntax, 1, ERR_STRING );
         return 1;
      }

      if ( args->next != NULL )
      {
         stack_push( stack, args->next );

         if ( evaluate() )
         {
            if ( !stop )
               print_err( ERR_EVAL, syntax, 2, -1 );
            return 1;
         }

         car2 = stack_pop( stack );

         if ( islist( car2->flags ) == 1 || numberp( car2->flags ) == 0 )
         {
            print_err( ERR_ARG_TYPE, syntax, 2, ERR_FIXNUM);
            return 1;
         }
      }
   }

   if ( ! isatty( 0 ) )
      return getline_from_file( syntax, 0 );

   {
      struct string *s, *after, *clip, *search;
      struct stack *offsets;
      unsigned char c;
      char *name, *original_s, *original_after, *old;
      int tabstop, result, eof, was_canon, name_len,
         original_len, after_len, offset;

      /*
       * Update LINES and COLS in case a sigwinch was caught by a child
       * process, and not us, leaving them inaccurate.
       */

      sigwinch_handler( 0 );
      sigwinch = 0;

      if ( LINES <= 0 || COLS <= 0 )
      {
         fprintf( stderr, "%s: cannot determine size of screen!", syntax );
         return 1;
      }

      if ( ( int)ce <= 0 || ( int)cm <= 0 )
         return getline_from_file( syntax, 0 );

      original_s = original_after = NULL;
      original_len = after_len = 0;

      putp( tgoto( cm, 0, LINES - 1 ));
      putp( ce );
      fflush( stdout );

      if ( car2 == NULL )
         tabstop = 8;
      else
         tabstop = number( car2->data.atom );

      if ( tabstop < -3 )
      {
         fprintf( stderr, "%s: argument two out of range: %d.\n", syntax, tabstop );
         return 1;
      }

      eof = 0;
   
      was_canon = mode;
      nocanon( syntax );

      if ( car1 != NULL )
      {
         name = car1->data.atom->data.string->string;
         name_len = car1->data.atom->data.string->length;
      }
      else
      {
         name = "";
         name_len = 0;
      }

      s = make_string();
      after = make_string();
      clip = make_string();
      search = make_string();

      offsets = make_stack();
      offset = 0;
      old = NULL;


      for( ; ; )
      {
         display_line( s, after, name, name_len, tabstop, offsets );
         result = read( 0, &c, 1 );

         if ( result < 0 )
         {
            if ( errno == EINTR || errno == EAGAIN )
               continue;

            if ( was_canon )
               canon( syntax );

            string_free( s );
            string_free( after );
            string_free( clip );
            string_free( search );
            stack_free( offsets );

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

            return 1;
         }
         else if ( result == 0 )
         {
            eof = 1;
            break;
         }

         switch( c )
         {
            /* C-k */
            case 11:
               if ( tabstop <= 0 )
               {
                  char *ptr;

                  string_truncate( clip );
                  for( ptr = after->str; *ptr; ++ptr )
                     string_prepend( clip, *ptr );

                  string_truncate( after );
               }
               break;

            /* C-y */
            case 25:
               if ( tabstop <= 0 && clip->used )
               {
                  char *ptr;

                  for( ptr = clip->str; *ptr ; ++ptr )
                     string_append( s, *ptr );
               }
               break;

            /* C-b */
            case '\002':
               if ( tabstop <= 0 && s->used )
               {
                  string_append( after, *( s->top - 1 ));
                  string_chop( s );
               }
               break;

            /* M-b */
            case 226:
               if ( tabstop <= 0 )
               {
                  while( s->used && !isalnum( s->str[ s->used - 1 ] ))
                  {
                     string_append( after, *( s->top - 1 ));
                     string_chop( s );
                  }

                  while( s->used && isalnum( s->str[ s->used - 1 ] ))
                  {
                     string_append( after, *( s->top - 1 ));
                     string_chop( s );
                  }
               }
               break;

            /* C-f */
            case '\006':
               if ( tabstop <= 0 && after->used )
               {
                  string_append( s, *( after->top - 1 ));
                  string_chop( after );
               }
               break;

            /* M-f */
            case 230:
               if ( tabstop <= 0 )
               {
                  while( after->used && !isalnum( after->str[ after->used - 1 ] ))
                  {
                     string_append( s, *( after->top - 1 ));
                     string_chop( after );
                  }

                  while( after->used && isalnum( after->str[ after->used - 1 ] ))
                  {
                     string_append( s, *( after->top - 1 ));
                     string_chop( after );
                  }

                  while( after->used && !isalnum( after->str[ after->used - 1 ] ))
                  {
                     string_append( s, *( after->top - 1 ));
                     string_chop( after );
                  }
               }
               break;

            /* C-a */
            case '\001':
               if ( tabstop <= 0 )
               {
                  int i;

                  for( i = s->used; i; --i )
                  {
                     string_append( after, *( s->top - 1 ));
                     string_chop( s );
                  }
               }
               break;

            /* C-e */
            case '\005':
               if ( tabstop <= 0 )
               {
                  while( after->used )
                  {
                     string_append( s, *( after->top - 1 ));
                     string_chop( after );
                  }
               }
               break;

            /* C-h */
            case '\010':
               if ( s->used )
               {
                  if ( s->str[ s->used - 1 ] == '\t' )
                  {
                     result = ( int)stack_pop( offsets );
                     offset -= result - 1;
                  }

                  if ( tabstop <= 0 )
                     string_assign( clip, s->top - 1, 1 );

                  string_chop( s );
               }
               break;

            /* C-d */
            case '\004':
               if ( s->used == 0 && after->used == 0 )
               {
                  eof = 1;
                  goto BREAK;
               }

               if ( tabstop <= 0 && after->used )
               {
                  string_assign( clip, after->top - 1, 1 );
                  string_chop( after );
               }
               break;

            /* C-u */
            case '\025':
               if ( tabstop <= 0 )
                  string_assign( clip, s->str, s->used );

               stack_truncate( offsets, offsets->used );
               string_truncate( s );
               offset = 0;
               break;

            /* C-x */
            case 24:
               if ( tabstop <= 0 )
               {
                  history_ptr = history->used;

                  if ( original_s != NULL )
                  {
                     string_assign( s, original_s, original_len );
                     string_assign( after, original_after, after_len );
                     string_truncate( search );

                     free( original_s );
                     free( original_after );

                     original_s = original_after = NULL;
                  }
               }
               break;

            /* C-n */
            case '\016':

            /* C-s */
            case '\023':
               if ( tabstop <= 0 )
               {
                  char *str;

                  str = NULL;

                  if ( c == '\016' )
                  {
                     str = forw_history();

                     if ( str != NULL )
                     {
                        string_assign( s, str, strlen( str ));
                        string_truncate( after );
                     }
                     else if ( original_s != NULL )
                     {
                        string_assign( s, original_s, original_len );
                        string_assign( after, original_after, after_len );
                        string_truncate( search );

                        free( original_s );
                        free( original_after );

                        original_s = original_after = NULL;
                     }
                  }
                  else
                  {
                     if ( ! search->used || old == NULL || strcmp( old, s->str ))
                        string_assign( search, s->str, s->used );

                     str = forw_search_history( search->str );

                     if ( str != NULL )
                     {
                        old = str;

                        if ( original_s == NULL )
                        {
                           original_s = str_dup( s->str, s->used );
                           original_after = str_dup( after->str, after->used );
                        }
                        string_assign( s, str, strlen( str ));
                        string_truncate( after );
                     }
                  }

               }
               break;

            /* C-p */
            case '\020':

            /* C-r */
            case '\022':
               if ( tabstop <= 0 )
               {
                  char *str;

                  str = NULL;

                  if ( c == '\020' )
                     str = back_history();
                  else
                  {
                     if ( ! search->used || old == NULL || strcmp( old, s->str ))
                        string_assign( search, s->str, s->used );

                     str = back_search_history( search->str );
                     if ( str != NULL )
                        old = str;
                  }

                  if ( str != NULL )
                  {
                     if ( original_s == NULL )
                     {
                        original_s = str_dup( s->str, s->used );
                        original_len = s->used;
                        original_after = str_dup( after->str, after->used );
                        after_len = after->used;
                     }

                     string_assign( s, str, strlen( str ));
                     string_truncate( after );
                  }
               }
               break;

            /* M-d */
            case 228:
               if ( tabstop <= 0 )
               {
                  string_truncate( clip );

                  if ( after->used && !isalnum( after->str[ after->used - 1 ] ))
                  {
                     do
                     {
                        string_append( clip, *( after->top - 1 ));
                        string_chop( after );
                     }
                     while( after->used && !isalnum( after->str[ after->used - 1 ] ));
                  }
                  else
                     while( after->used && isalnum( after->str[ after->used - 1 ] ))
                     {
                        string_append( clip, *( after->top - 1 ));
                        string_chop( after );
                     }
               }
               break;

            /* C-w */
            case '\027':
               if ( tabstop <= 0 )
                  string_truncate( clip );

               if ( s->used && !isalnum( s->str[ s->used - 1 ] ))
               {
                  while( s->used && !isalnum( s->str[ s->used - 1 ] ))
                  {
                     if ( s->str[ s->used - 1 ] == '\t' )
                     {
                        result = ( int )stack_pop( offsets );
                        offset -= result - 1;
                     }

                     if ( tabstop <= 0 )
                        string_prepend( clip, *( s->top - 1 ));

                     string_chop( s );
                  }
               }
               else
                  while( s->used && isalnum( s->str[ s->used - 1 ] ))
                  {
                     if ( tabstop <= 0 )
                        string_prepend( clip, *( s->top - 1 ));

                     string_chop( s );
                  }
               break;

            /* tab */
            case '\011':
               if ( tabstop > 0 )
               {
                  result = tabstop - ( s->used + offset ) % tabstop;
                  offset += result - 1;
                  stack_push( offsets, ( void *)result );
                  string_append( s, c );
               }
               else
               {
                  char *ptr, *ptr2;
                  int length, flag;

                  flag = 0;

                  if ( s->used )
                  {
                     ptr = &s->str[ s->used - 1 ];
                     while( ptr > s->str && !isspace( *ptr ))
                        --ptr;

                     if ( *ptr == ' ' || *ptr == '/' || *ptr == '.' )
                        ++flag;

                     while( isspace( *ptr ))
                        ++ptr;
                  }
                  else
                     ptr = "";

                  if (( tabstop == -1 || tabstop == -3 ) && ! flag )
                  {
                     struct string *p;

                     p = complete_from_path( syntax, s->str, s->used, 0 );

                     if ( p != NULL )
                     {
                        string_assign( s, p->str, p->used );
                        free( p );
                     }
                  }
                  else
                  {
                     length = strlen( ptr );

                     ptr2 = ( char *)complete( ptr, 1, 0,
                           (( tabstop == -2 || tabstop == - 3 ) ? 0 : 1 ));

                     length = s->used - length;
                     while( s->used > length )
                        string_chop( s );

                     for( ptr = ptr2; *ptr; ++ptr )
                        string_append( s, *ptr );

                     if ( totally_complete )
                        string_append( s, ' ' );

                     free( ptr2 );
                  }
               }
               break;

            case '\r':
            case '\n':
               string_prepend( after, '\n' );
               fwrite( "\r\n", 2, 1, stdout );
               goto BREAK;

            default:
               if ( c > 31 )
                  string_append( s, c );
               break;

         } /* end of switch */
      } /* end of for loop */

   BREAK:
      if ( was_canon )
         canon( syntax );

      stack_free( offsets );
      string_free( clip );
      string_free( search );

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

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

      while( after->used )
      {
         string_append( s, *( after->top - 1 ));
         string_chop( after );
      }

      string_free( after );

      if ( !s->used && eof )
         stack_push( stack, make_atom_from_number( 0 ));
      else
      {
         stack_push( stack, make_atom_from_string( s->str, s->used ));
         if ( tabstop <= 0 )
         {
            add_history( s );
            history_ptr = history->used;
         }
      }

      string_free( s );
   }

   return 0;
}

int do_fixnump( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   if ( islist( car->flags ))
   {
      stack_push( stack, make_atom_from_number( 0 ));
      return 0;
   }

   stack_push( stack, make_atom_from_number( ( numberp( car->flags ) )));

   return 0;
}

int do_stringp( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   if ( islist( car->flags ) || numberp( car->flags ))
   {
      stack_push( stack, make_atom_from_number( 0 ));
      return 0;
   }

   if ( type( car->data.atom->flags ) == ATOM_STRING )
      stack_push( stack, make_atom_from_number( 1 ));
   else
      stack_push( stack, make_atom_from_number( 0 ));

   return 0;
}

int do_split( char *syntax, struct object *args )
{
   struct object *car1, *car2, *car3;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   car1 = args;
   car2 = args->next;

   if ( car2 == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 2, -1 );
      return 1;
   }

   car3 = car2->next;

   if ( car3 != NULL )
   {
      if ( car3->next )
      {
         print_err( ERR_MORE_ARGS, syntax, 3, -1 );
         return 1;
      }
   }

   stack_push( stack, car1 );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, -1 );
      return 1;
   }

   stack_push( stack, car2 );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 2, -1 );
      return 1;
   }

   if ( car3 != NULL )
   {
      stack_push( stack, car3 );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 3, -1 );
         return 1;
      }

      car3 = stack_pop( stack );

      if ( numberp( car3->flags ) == 0 || islist( car3->flags ) == 1 )
      {
         print_err( ERR_ARG_TYPE, syntax, 3, ERR_FIXNUM);
         return 1;
      }

      if ( number( car3->data.atom ) <= 0 )
      {
         fprintf( stderr, "%s: argument 3 <= 0.\n", syntax );
         return 1;
      }
   }

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   if ( numberp( car1->flags ) ||
        islist( car1->flags ) == 1 ||
        type( car1->data.atom->flags )!= ATOM_STRING )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_STRING );
      return 1;
   }

   if ( numberp( car2->flags ) ||
        islist( car2->flags ) == 1 ||
        type( car2->data.atom->flags ) != ATOM_STRING )
   {
      print_err( ERR_ARG_TYPE, syntax, 2, ERR_STRING );
      return 1;
   }

   {
      struct object *result;
      char *tmp1, *tmp2, *tmp3, *tmp4 = NULL, **results;
      int i, len, length, arg3, duped = 0;

      results = NULL;

      if ( car2->data.atom->data.string->length == 0 )
      {
         result = make_object();
         setlist( result->flags );
         result->data.head = car2;
         stack_push( stack, result );
         return 0;
      }

      tmp1 = car1->data.atom->data.string->string;
      tmp2 = car2->data.atom->data.string->string;
      length = car2->data.atom->data.string->length;
      len = length;

      arg3 = -1;

      if ( car3 != NULL )
      {
         if ( number( car3->data.atom ) <= length )
            arg3 = ( number( car3->data.atom )) - 1;
      }

      if ( arg3 == 0 )
      {
         result = make_object();
         setlist( result->flags );
         result->data.head =
            make_atom_from_string( car2->data.atom->data.string->string,
                                   car2->data.atom->data.string->length );
         stack_push( stack, result );
         return 0;
      }
      else if ( *tmp1 == '\0' )
      {
         results = ( char **)memory( sizeof( char * ) * ( length + 1 ));

         for( i = 0; i <= length; ++i )
            results[ i ] = NULL;

         if ( arg3 > 0 && arg3 < length )
            length = arg3;

         for( i = 0; i < length; ++i )
         {
            results[ i ] = ( char *)memory( 2 );
            results[ i ][ 0 ] = tmp2[ i ];
            results[ i ][ 1 ] = '\0';
         }

         if ( arg3 > 0 && arg3 == length )
            results[ i ] = str_dup( &tmp2[ i ], len - i );
      }
      else
      {
         char *start;

         results = ( char **)memory( sizeof( char * ) * ( length + 1 ));

         for( i = 0; i <= length; ++i )
            results[ i ] = NULL;

         i = 0;
         tmp4 = tmp3 = str_dup( tmp2, strlen( tmp2 ));
         duped = 1;

         if ( arg3 > 0 && arg3 < length )
            length = arg3;

         while( i < length && ( start = strsep( &tmp3, tmp1 )) != NULL )
            results[ i++ ] = start;

         if ( arg3 > 0 && arg3 == length && tmp3 != NULL )
            results[ i ] = tmp3;
      }

      result = make_object();
      setlist( result->flags );
      stack_push( stack, result );

      if ( *results == NULL )
         result->data.head = car2;
      else
      {
         char **ptr;
         struct object **ptr2;

         ptr2 = &result->data.head;

         for( ptr = results; *ptr != NULL; ++ptr )
         {
            *ptr2 = make_atom_from_string( *ptr, strlen( *ptr ));
            ptr2 = &( *ptr2 )->next;
            if ( duped == 0 )
               free( *ptr );
         }
      }

      free( results );

      if ( duped )
         free( tmp4 );
   }

   return 0;
}

int get_join_args( struct object *args, int i, char *syntax )
{
   struct object *ptr;

   for( ptr = args; ptr != NULL; ptr = ptr->next, ++i )
   {
      if ( islist( ptr->flags ))
      {
         if ( ptr->data.head == NULL )
         {
            print_err( ERR_ARG_TYPE, syntax, i + 1, ERR_STRING );
            return 0;
         }

         if (( i = get_join_args( ptr->data.head, i, syntax )) == 0 )
            return 0;

         --i;
      }
      else
      {
         if ( numberp( ptr->flags ) || type( ptr->data.atom->flags ) != ATOM_STRING )
         {
            print_err( ERR_ARG_TYPE, syntax, i + 1, ERR_STRING );
            return 0;
         }

         stack_push( stack, ptr );
      }
   }

   return i;
}

int process_join_args( struct object *args, int i, char *syntax )
{
   struct object *ptr, *result;

   for( ptr = args; ptr != NULL; ptr = ptr->next, ++i )
   {
      stack_push( stack, ptr );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, i + 1, -1 );
         return 0;
      }

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

      if ( numberp( result->flags ))
      {
         print_err( ERR_ARG_TYPE, syntax, i + 1, ERR_STRING );
         return 0;
      }
      else if ( islist( result->flags ))
      {
         int j;

         if ( result->data.head == NULL )
         {
            print_err( ERR_ARG_TYPE, syntax, i + 1, ERR_STRING );
            return 0;
         }

         j = stack->used;

         if (( i = get_join_args( result->data.head, i, syntax )) == 0 )
            return 0;

         --i;

         for( ; j < stack->used; ++j )
            stack->values[ j - 1 ] = stack->values[ j ];

         stack_pop( stack );
      }
      else if ( type( result->data.atom->flags ) != ATOM_STRING )
      {
         print_err( ERR_ARG_TYPE, syntax, i + 1, ERR_STRING );
         return 0;
      }
   }

   return i;
}

int do_join( char *syntax, struct object *args )
{
   struct object *car1, *car2;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   car1 = args;
   car2 = car1->next;

   if ( car2 == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 2, -1 );
      return 1;
   }

   stack_push( stack, car1 );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, -1 );
      return 1;
   }

   {
      int i, j, len;
      char *tmp;
      struct string *buffer;

      if (( i = process_join_args( car2, 1, syntax )) == 0 )
         return 1;

      car1 = stack->values[ stack->used - i ];

      if ( numberp( car1->flags ) ||
           islist( car1->flags ) == 1 ||
           type( car1->data.atom->flags ) != ATOM_STRING )
      {
         print_err( ERR_ARG_TYPE, syntax, 1, ERR_STRING );
         return 1;
      }

      buffer = make_string();
      string_append( buffer, '"' );

      for( j = i - 1; j; --j )
      {
         struct object *item;

         item = stack->values[ stack->used - j ];
         tmp = item->data.atom->data.string->string;
         len = item->data.atom->data.string->length;

         while( len-- )
            string_append( buffer, *tmp++ );

         if ( j != 1 )
         {
            tmp = car1->data.atom->data.string->string;
            len = car1->data.atom->data.string->length;

            while( len-- )
               string_append( buffer, *tmp++ );
         }
      }

      stack_truncate( stack, i );
      stack_push( stack, make_atom_directly_from_string( buffer->str, buffer->used ));
      free( buffer );
   }

   return 0;
}

int apply_regexp( regex_t *regexp, char *the_string, int len, int show_offset, int first )
{
   struct object **ptr = NULL;
   struct string *buffer;
   regmatch_t matches[ 20 ];
   int result, length, i;

   matches[ 0 ].rm_so = 0;
   matches[ 0 ].rm_eo = len;

   result = regexec( regexp, the_string,
                     ( show_offset == 2 ? 1 : 20 ),
                     matches,
                     ( first ? REG_STARTEND : REG_NOTBOL | REG_STARTEND ));

   stack_push( stack, make_object());
   setlist( ( *( struct object **)stack->top )->flags );

   if ( result )
   {
      char err[ 80 ];

      if ( result == REG_NOMATCH )
         return 0;

      regerror( result, regexp, err, sizeof( err ));
      fprintf( stderr, "apply_regexp: regexec: %s.\n", err );
      return 1;
   }

   switch ( show_offset )
   {
      case 0:
         ptr = &( *( struct object **)stack->top )->data.head;
         break;

      case 1:
         ( *( struct object **)stack->top )->data.head =
            make_atom_from_number( matches[ 0 ].rm_so );
         ( *( struct object **)stack->top )->data.head->next =
            make_atom_from_number( matches[ 0 ].rm_eo );
         ptr = &( *( struct object **)stack->top )->data.head->next->next;
         break;

      case 2:
         ( *( struct object **)stack->top )->data.head =
            make_atom_from_number( matches[ 0 ].rm_so );
         ( *( struct object **)stack->top )->data.head->next =
            make_atom_from_number( matches[ 0 ].rm_eo );
         return 0;
   }

   buffer = make_string();

   for( i = 0; i < 20; ++i )
   {
      if ( matches[ i ].rm_so >= 0 )
      {
         int j;

         length = matches[ i ].rm_so + matches[ i ].rm_eo - matches[ i ].rm_so;

         for( j = matches[ i ].rm_so; j < length; ++j )
            string_append( buffer, the_string[ j ] );
      }

      *ptr = make_atom_from_string( buffer->str, buffer->used );
      ( *ptr )->next = NULL;
      ptr = &( *ptr )->next;

      string_truncate( buffer );
   }

   string_free( buffer );

   return 0;
}

int do_matches( char *syntax, struct object *args )
{
   struct object *car1, *car2;

   stack_push( arg_stack, ( void *)ERR_REGEXP );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   return apply_regexp( car1->data.atom->data.regexp,
                        car2->data.atom->data.string->string,
                        car2->data.atom->data.string->length,
                        0,
                        1 );
}

int do_match( char *syntax, struct object *args )
{
   struct object *car1, *car2;

   stack_push( arg_stack, ( void *)ERR_REGEXP );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   return apply_regexp( car1->data.atom->data.regexp,
                        car2->data.atom->data.string->string,
                        car2->data.atom->data.string->length,
                        2,
                        1 );
}

int add_char( struct string *buffer, char *ptr, int change_case )
{
   switch( change_case )
   {
      case 0:
         string_append( buffer, *ptr );
         break;

      case 1:
         string_append( buffer, toupper( *ptr ));
         change_case = 0;
         break;

      case 2:
         string_append( buffer, toupper( *ptr ));
         break;

      case 3:
         string_append( buffer, tolower( *ptr ));
         change_case = 0;
         break;

      case 4:
         string_append( buffer, tolower( *ptr ));
         break;
   }

   return change_case;
}

int do_substitute( char *syntax, struct object *args )
{
   struct object *car1, *car2, *car3, *car4;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   car1 = args;
   car2 = car1->next;

   if ( car2 == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 2, -1 );
      return 1;
   }

   car3 = car2->next;

   if ( car3 == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 3, -1 );
      return 1;
   }

   stack_push( stack, car1 );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, -1 );
      return 1;
   }

   stack_push( stack, car2 );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 2, -1 );
      return 1;
   }

   stack_push( stack, car3 );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 3, -1 );
      return 1;
   }

   car4 = car3->next;

   if ( car4 != NULL )
   {
      if ( car4->next != NULL )
      {
         print_err( ERR_MORE_ARGS, syntax, 4, -1 );
         return 1;
      }

      stack_push( stack, car4 );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 4, -1 );
         return 1;
      }

      car4 = stack_pop( stack );

      if ( islist( car4->flags ) == 1 || numberp( car4->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 4, ERR_FIXNUM );
         return 1;
      }
   }

   car3 = stack_pop( stack );

   if ( islist( car3->flags ) == 1 ||
        numberp( car3->flags ) ||
        type( car3->data.atom->flags ) != ATOM_STRING )
   {
      print_err( ERR_ARG_TYPE, syntax, 3, ERR_STRING );
      return 1;
   }

   car2 = stack_pop( stack );

   if ( islist( car2->flags ) == 1 ||
       numberp( car2->flags ) ||
       type( car2->data.atom->flags ) != ATOM_STRING )
   {
      print_err( ERR_ARG_TYPE, syntax, 2, ERR_STRING );
      return 1;
   }

   car1 = stack_pop( stack );

   if ( islist( car1->flags ) == 1 ||
       numberp( car1->flags ) ||
       type( car1->data.atom->flags ) != ATOM_REGEXP )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_REGEXP );
      return 1;
   }

   {
      char *tmp1, *tmp2, *tmp3, *tmp4, *subs[ 11 ], *ptr, *old_tmp4;
      struct object *obj;
      struct string *buffer;
      int first, arg4, len3, escape, i, begin, end, count, change_case;
      regex_t *rx;

      rx = car1->data.atom->data.regexp;

      arg4 = ( car4 == NULL ? 1 : number( car4->data.atom ));

      tmp2 = car2->data.atom->data.string->string;
      tmp3 = car3->data.atom->data.string->string;
      len3 = car3->data.atom->data.string->length;
      tmp4 = tmp3;

      change_case = 0;

      buffer = make_string();
      count = 0;
      old_tmp4 = NULL;

      first = 1;

      for( ; ; )
      {
         if ( !first && ( tmp4 - tmp3 ) >= len3 )
            break;

         if ( tmp4 == old_tmp4 )
            string_append( buffer, *tmp4++ );

         old_tmp4 = tmp4;

         if ( apply_regexp( rx, tmp4, len3 - ( tmp4 - tmp3 ), 1, first ))
            return 1;

         first = 0;

         car1 = stack_pop( stack );

         if ( car1->data.head == NULL )
            break;

         begin = number( car1->data.head->data.atom );
         end = number( car1->data.head->next->data.atom );

         car1->data.head->flags = 0;
         car1->data.head->next->flags = 0;

         i = 0;

         for( obj = car1->data.head->next->next; obj != NULL; obj = obj->next )
         {
            subs[ i++ ] = obj->data.atom->data.string->string;

            if ( i > 10 )
               break;
         }

         ptr = tmp4;

         if ( begin )
            for( i = 0; i < begin; ++i )
               string_append( buffer, *ptr++ );

         escape = 0;

         for( ptr = tmp2; *ptr; ++ptr )
         {
            char c[ 2 ];

            if ( *ptr == '\\' )
            {
               if ( escape )
                  string_append( buffer, '\\' );

               escape ^= 1;
               continue;
            }
            else if ( escape )
            {
               c[ 0 ] = *ptr;
               c[ 1 ] = '\0';

               escape = 0;

               if ( *ptr >= '1' && *ptr <= '9' )
               {
                  tmp1 = subs[ atoi( c ) ];
                  while( *tmp1 )
                  {
                     change_case = add_char( buffer, tmp1, change_case );
                     ++tmp1;
                  }
                  continue;
               }

               switch( *ptr )
               {
                  case '0':
                     tmp1 = subs[ 10 ];
                     while( *tmp1 )
                     {
                        change_case = add_char( buffer, tmp1, change_case );
                        ++tmp1;
                     }
                     continue;

                  case '&':
                     tmp1 = subs[ 0 ];
                     while( *tmp1 )
                     {
                        change_case = add_char( buffer, tmp1, change_case );
                        ++tmp1;
                     }
                     continue;

                  case 't':
                     string_append( buffer, '\t' );
                     continue;

                  case 'b':
                     string_append( buffer, ' ' );
                     continue;

                  case 'U':
                     change_case = 2;
                     continue;

                  case 'u':
                     change_case = 1;
                     continue;

                  case 'L':
                     change_case = 4;
                     continue;

                  case 'l':
                     change_case = 3;
                     continue;

                  case 'e':
                     change_case = 0;
                     continue;

                  case '\\':
                     string_append( buffer, '\\' );
                     continue;

                  default:
                     change_case = add_char( buffer, ptr, change_case );
                     continue;
               }
            }

            change_case = add_char( buffer, ptr, change_case );
         }

         tmp4 = &tmp4[ end ];

         if ( ++count == arg4 )
            break;
      }

      for( ptr = tmp4; *ptr; ++ptr )
         change_case = add_char( buffer, ptr, change_case );

      stack_push( stack, make_atom_from_string( buffer->str, buffer->used ));
      string_free( buffer );
   }

   return 0;
}

int do_regcomp( char *syntax, struct object *args )
{
   struct string *new;
   char *ptr, *tmp;
   regex_t *regexp;
   int escape, result, len, flags;
   struct object *car1, *car2, *car3;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   car1 = args;
   car2 = car1->next;
   car3 = NULL;

   if ( car2 != NULL )
   {
      car3 = car2->next;

      if ( car3 != NULL && car3->next != NULL )
      {
         print_err( ERR_MORE_ARGS, syntax, 3, -1 );
         return 1;
      }
   }

   stack_push( stack, car1 );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, -1 );
      return 1;
   }

   if ( car2 != NULL )
   {
      stack_push( stack, car2 );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 2, -1 );
         return 1;
      }

      if ( car3 != NULL )
      {
         stack_push( stack, car3 );

         if ( evaluate() )
         {
            if ( !stop )
               print_err( ERR_EVAL, syntax, 3, -1 );
            return 1;
         }

         car3 = stack_pop( stack );

         if ( numberp( car3->flags ) == 0 )
         {
            print_err( ERR_ARG_TYPE, syntax, 3, ERR_FIXNUM );
            return 1;
         }
      }

      car2 = stack_pop( stack );

      if ( numberp( car2->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 2, ERR_FIXNUM );
         return 1;
      }
   }

   car1 = stack_pop( stack );

   if ( islist( car1->flags ) || numberp( car1->flags )
        || type( car1->data.atom->flags ) != ATOM_STRING )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_STRING );
      return 1;
   }

   ptr = car1->data.atom->data.string->string;
   len = car1->data.atom->data.string->length;

   escape = 0;

   new = make_string();

   for( ; len; --len )
   {
      if ( *ptr == '\\' )
      {
         if ( car3 == NULL || number( car3->data.atom ) == 0 )
         {
            escape ^= 1;

            if ( !escape )
            {
               string_append( new, '\\' );
               string_append( new, '\\' );
            }

            ++ptr;
            continue;
         }
      }

      if ( escape )
      {
         switch( *ptr )
         {
            case 'b':
               string_append( new, ' ' );
               break;

            case 't':
               string_append( new, '\t' );
               break;

            case 'r':
               string_append( new, '\r' );
               break;

            case 'n':
               string_append( new, '\n' );
               break;

            case '>':
               tmp = "[[:>:]]";
               while( *tmp )
                  string_append( new, *tmp++ );
               break;

            case '<':
               tmp = "[[:<:]]";
               while( *tmp )
                  string_append( new, *tmp++ );
               break;

            case '?':
               string_append( new, '\\' );
               string_append( new, '?' );
               break;

            case '+':
               string_append( new, '\\' );
               string_append( new, '+' );
               break;

            case '^':
               string_append( new, '\\' );
               string_append( new, '^' );
               break;

            case '$':
               string_append( new, '\\' );
               string_append( new, '$' );
               break;

            case '.':
               string_append( new, '\\' );
               string_append( new, '.' );
               break;

            case '[':
               string_append( new, '\\' );
               string_append( new, '[' );
               break;

            case '(':
               string_append( new, '\\' );
               string_append( new, '(' );
               break;

            case ')':
               string_append( new, '\\' );
               string_append( new, ')' );
               break;

            case '|':
               string_append( new, '\\' );
               string_append( new, '|' );
               break;

            case '{':
               string_append( new, '\\' );
               string_append( new, '{' );
               break;

            case '*':
               string_append( new, '\\' );
               string_append( new, '*' );
               break;

            default:
               string_append( new, *ptr );
         }
      }
      else
         string_append( new, *ptr );

      ++ptr;
      escape = 0;
   }

   regexp = ( regex_t *)memory( sizeof( regex_t ));
   regexp->re_endp = &new->str[ new->used ];
   flags = REG_EXTENDED | REG_PEND;

   if ( car2 != NULL && number( car2->data.atom ) )
      flags |= REG_ICASE;

   if ( car3 != NULL && number( car3->data.atom ) )
   {
      flags &= ~REG_EXTENDED;
      flags |= REG_NOSPEC;
   }

   result = regcomp( regexp, new->str, flags );

   if ( result )
   {
      char err[ 83 ];

      regerror( result, regexp, err, sizeof( err ) - 1 );
      free( regexp );
      string_free( new );

      stack_push( stack, make_atom_from_string( err, strlen( err )));
      return 0;
   }

   string_free( new );

   stack_push( stack, make_atom_from_regexp( regexp ));

   return 0;
}

int do_sort( char *syntax, struct object *args )
{
   struct object *ptr, *result, **ptr2;
   struct stack *items;
   int i, first = 1, type = 0;

   for( i = 1, ptr = args; ptr != NULL; ptr = ptr->next, ++i )
   {
      stack_push( stack, ptr );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, i, -1 );
         return 1;
      }

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

      if ( islist( result->flags ))
      {
         print_err( ERR_ARG_TYPE, syntax, i, ERR_ATOM );
         return 1;
      }

      if ( numberp( result->flags ) == 0 &&
           type( result->data.atom->flags ) != ATOM_STRING  )
      {
         fprintf( stderr, "%s: arguments must either be all strings "
                  "or all numbers.\n", syntax );
         return 1;
      }

      if ( first && numberp( result->flags ) == 0 )
         type = 1;

      first = 0;

      if ( type )
      {
         if ( numberp( result->flags ) ||
              type( result->data.atom->flags ) != ATOM_STRING )
         {
            print_err( ERR_ARG_TYPE, syntax, i, ERR_STRING );
            return 1;
         }
      }
      else
      {
         if ( numberp( result->flags ) ==  0 )
         {
            print_err( ERR_ARG_TYPE, syntax, i, ERR_FIXNUM );
            return 1;
         }
      }
   }

   items = make_stack();
   while( --i )
   {
      result = stack_pop( stack );
      stack_push( items, ( type ? ( struct object *)result->data.atom->data.string :
                                  ( struct object *)number( result->data.atom )));
   }

   result = make_object();
   setlist( result->flags );
   stack_push( stack, result );

   ptr2 = &result->data.head;

   if ( type )
   {
      qsort( items->values, items->used, sizeof( void * ),
             compare_strings );

      for( i = 0; i < items->used; ++i )
      {
         *ptr2 = make_atom_from_string(
            (( struct lstring *)items->values[ i ] )->string,
            (( struct lstring *)items->values[ i ] )->length );
         ( *ptr2 )->next = NULL;
         ptr2 = &( *ptr2 )->next;
      }
   }
   else
   {
      qsort( items->values, items->used, sizeof( void * ),
             compare_numbers );

      for( i = 0; i < items->used; ++i )
      {
         *ptr2 = make_atom_from_number( ( int )items->values[ i ] );
         ( *ptr2 )->next = NULL;
         ptr2 = &( *ptr2 )->next;
      }
   }

   stack_free( items );

   return 0;
}

int do_sortcar( char *syntax, struct object *args )
{
   struct object *car, *ptr, **ptr2 = NULL;
   int type = 0, i, first = 1;

   stack_push( arg_stack, ( void *)ERR_LIST );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   i = 1;

   for( ptr = car->data.head; ptr != NULL; ptr = ptr->next )
   {
      if ( islist( ptr->flags ) == 0 )
      {
         fprintf( stderr, "%s: list element %d is not a sublist.\n", syntax, i );
         return 1;
      }

      if ( islist( ptr->data.head->flags ))
      {
         fprintf( stderr, "%s: car of sublist %d is not an atom.\n",
                  syntax, i );
         return 1;
      }

      if ( first )
      {
         if ( numberp( ptr->data.head->flags ))
            type = 0;
         else if ( type( ptr->data.head->data.atom->flags ) == ATOM_STRING )
            type = 1;
         else
         {
            fprintf( stderr, "%s: the car of sublist %d is neither a number"
                     "nor a string.\n", syntax, i );
            return 1;
         }

         first = 0;
      }
      else if ( type )
      {
         if ( numberp( ptr->data.head->flags ) ||
              type( ptr->data.head->data.atom->flags ) != ATOM_STRING )
         {
            fprintf( stderr, "%s: the car of sublist %d is not a string.\n",
                     syntax, i );
            return 1;
         }
      }
      else
      {
         if ( numberp( ptr->data.head->flags ) == 0 )
         {
            fprintf( stderr, "%s: the car of sublist %d is not a number.\n",
                     syntax, i );
            return 1;
         }
      }

      ++i;
   }

   {
      struct object *result;
      struct stack *items;

      items = make_stack();

      for( ptr = car->data.head; ptr != NULL; ptr = ptr->next )
         stack_push( items, ptr );

      result = make_object();
      stack_push( stack, result );
      setlist( result->flags );

      ptr2 = &result->data.head;

      if ( type )
         qsort( items->values, items->used, sizeof( struct object * ),
                compare_car_strings );
      else
         qsort( items->values, items->used, sizeof( struct object * ),
                compare_car_numbers );

      for( i = 0; i < items->used; ++i )
      {
         *ptr2 = duplicate_object( ( struct object *)items->values[ i ] );
         ptr2 = &( *ptr2 )->next;
      }

      *ptr2 = NULL;
      stack_free( items );
   }

   return 0;
}

int do_sortlist( char *syntax, struct object *args )
{
   struct object *car, *ptr, **ptr2 = NULL;
   int type = 0, i, first = 1;

   stack_push( arg_stack, ( void *)ERR_LIST );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   for( i = 1, ptr = car->data.head; ptr != NULL; ptr = ptr->next, ++i )
   {
      if ( islist( ptr->flags ) == 1 )
      {
         fprintf( stderr, "%s: list element %d is not an atom.\n", syntax, i );
         return 1;
      }

      if ( first )
      {
         if ( numberp( ptr->flags ))
            type = 0;
         else if ( type( ptr->data.atom->flags ) == ATOM_STRING )
            type = 1;
         else
         {
            fprintf( stderr, "%s: list element %d is neither a number nor a "
                     "string.\n", syntax, i );
            return 1;
         }

         first = 0;

      }
      else if ( type )
      {
         if ( numberp( ptr->flags ) || type( ptr->data.atom->flags ) != ATOM_STRING )
         {
            fprintf( stderr, "%s: list element %d is not a string.\n",
                     syntax, i );
            return 1;
         }
      }
      else
      {
         if ( numberp( ptr->flags ) == 0 )
         {
            fprintf( stderr, "%s: list element %d is not a number.\n",
                     syntax, i );
            return 1;
         }
      }
   }

   {
      struct object *result;
      struct stack *items;

      items = make_stack();

      for( ptr = car->data.head; ptr != NULL; ptr = ptr->next )
      {
         if ( type )
            stack_push( items, ptr->data.atom->data.string );
         else
            stack_push( items, ( void *)number( ptr->data.atom ));
      }

      result = make_object();
      setlist( result->flags );
      stack_push( stack, result );

      ptr2 = &result->data.head;

      if ( type )
      {
         qsort( items->values, items->used, sizeof( void * ),
                compare_strings );

         for( i = 0; i < items->used; ++i )
         {
            *ptr2 = make_atom_from_string(
               (( struct lstring *)items->values[ i ] )->string,
               (( struct lstring *)items->values[ i ] )->length );
            ( *ptr2 )->next = NULL;
            ptr2 = &( *ptr2 )->next;
         }
      }
      else
      {
         qsort( items->values, items->used, sizeof( void * ),
                compare_numbers );

         for( i = 0; i < items->used; ++i )
         {
            *ptr2 = make_atom_from_number( ( int )items->values[ i ] );
            ( *ptr2 )->next = NULL;
            ptr2 = &( *ptr2 )->next;
         }
      }

      stack_free( items );
   }

   return 0;
}

int do_while( char *syntax, struct object *args )
{
   struct object *car, *result;
   int i;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   car = args;
   i = stack->used;

   for( ; ; )
   {
CONTINUE:
      stack_push( stack, car );

      if ( evaluate() )
      {
         if ( !stop )
            fprintf( stderr, "%s: evaluation of test clause failed.\n", syntax );

         return 1;
      }

      result = stack_pop( stack );

      if (( islist( result->flags ) == 1 && result->data.head == NULL ) ||
            result->data.atom == NULL ||
            result->data.atom == empty->data.atom )
         break;

      if ( args->next != NULL )
      {
         int j;
         struct object *ptr;

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

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

               if ( next_iteration )
               {
                  next_iteration = 0;
                  stop = 0;
                  thrown = NULL;
                  stack_truncate( stack, stack->used - i );
                  goto CONTINUE;
               }

               return 1;
            }

            stack_pop( stack );
         }
      }
   }

   stack_push( stack, result );

   return 0;
}

int do_until( char *syntax, struct object *args )
{
   struct object *car, *result;
   int i;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   car = args;
   i = stack->used;

   for( ; ; )
   {
      stack_push( stack, car );

      if ( evaluate() )
      {
         if ( !stop )
            fprintf( stderr, "%s: evaluation of test clause failed.\n", syntax );

         return 1;
      }

      result = stack_pop( stack );

      if ( !(( islist( result->flags ) == 1 && result->data.head == NULL ) ||
               result->data.atom == NULL ||
               result->data.atom == empty->data.atom ))
         break;

      if ( args->next != NULL )
      {
         if ( do_progn( syntax, car->next ))
         {
            if ( !stop )
               fprintf( stderr, "%s: evaluation of body failed.\n", syntax );

            if ( next_iteration )
            {
               next_iteration = 0;
               stop = 0;
               thrown = NULL;
               stack_truncate( stack, stack->used - i );
               continue;
            }

            return 1;
         }

         stack_pop( stack );
      }
   }

   stack_push( stack, result );

   return 0;
}

int do_do( char *syntax, struct object *args )
{
   struct object *result = NULL;
   int i;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   i = stack->used;

   for( ; ; )
   {
      int j;
      struct object *ptr;

CONTINUE:
      for( j = 1, ptr = args; ptr != NULL; ptr = ptr->next, ++j )
      {
         stack_push( stack, ptr );

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

            if ( next_iteration )
            {
               next_iteration = 0;
               stop = 0;
               thrown = NULL;
               stack_truncate( stack, stack->used - i );
               goto CONTINUE;
            }

            return 1;
         }

         result = stack_pop( stack );
      }

      if (( islist( result->flags ) == 1 && result->data.head == NULL ) ||
            result->data.atom == NULL ||
            result->data.atom == empty->data.atom )
         break;
   }

   stack_push( stack, result );

   return 0;
}

int do_throw( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   thrown = stack_pop( stack );
   stop = 1;

   return 1;
}

int do_catch( char *syntax, struct object *args )
{
   int i;

   i = stack->used;

   if ( do_progn( syntax, args ))
   {
      if ( !stop )
      {
         fprintf( stderr, "%s: evaluation of body failed.\n", syntax );
         return 1;
      }
      else if ( thrown != NULL )
      {
         stack_truncate( stack, stack->used - i );
         stack_push( stack, thrown );
         thrown = NULL;
         stop = 0;
      }
      else
         return 1;
   }

   return 0;
}

int do_die( char *syntax, struct object *args )
{
   if ( args != NULL )
      do_warn( syntax, args );

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

   return 1;
}

int do_stringify( char *syntax, struct object *args )
{
   int i, len;
   struct object *item, *result, *ptr;
   struct stack *myatoms;
   char *tmp;
   struct string *final;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   for( i = 1, item = args; item != NULL; item = item->next, ++i )
   {
      stack_push( stack, item );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, i, -1 );
         return 1;
      }

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

      if ( islist( result->flags ) == 1 )
      {
         print_err( ERR_ARG_TYPE, syntax, i, ERR_ATOM );
         return 1;
      }
   }

   final = make_string();
   myatoms = make_stack();

   while( --i )
      stack_push( myatoms, stack_pop( stack ));

   while( myatoms->used )
   {
      ptr = stack_pop( myatoms );

      if ( numberp( ptr->flags ) )
      {
         char buffer[ 64 ];

         snprintf( buffer, sizeof( buffer ), "%i", number( ptr->data.atom ));
         tmp = buffer;

         while( *tmp )
            string_append( final, *tmp++ );
      }
      else if ( type( ptr->data.atom->flags ) == ATOM_STRING )
      {
         tmp = ptr->data.atom->data.string->string;
         len = ptr->data.atom->data.string->length;

         while( len-- )
            string_append( final, *tmp++ );
      }
      else
      {
         tmp = ptr->data.atom->syntax;
         len = ptr->data.atom->len;

         while( len-- )
            string_append( final, *tmp++ );
      }
   }

   stack_push( stack, make_atom_from_string( final->str, final->used ));

   stack_free( myatoms );
   string_free( final );

   return 0;
}

int do_digitize( char *syntax, struct object *args )
{
   struct object *car;
   int i;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   i = atoi( car->data.atom->data.string->string );
   stack_push( stack, make_atom_from_number( i ));

   return 0;
}

int do_intern( char *syntax, struct object *args )
{
   struct object *car;
   char *ptr;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   ptr = car->data.atom->data.string->string;

   if ( *ptr == '\0' )
   {
      fprintf( stderr, "%s: empty string passed as argument.\n", syntax );
      return 1;
   }
   else if ( *ptr < 58 && *ptr > 47 )
   {
      fprintf( stderr, "%s: symbols cannot start with a numerical character.\n",
               syntax );
      return 1;
   }

   for( ++ptr; *ptr; ++ptr )
      if ( *ptr < 48 ||
           *ptr > 122 ||
           ( *ptr > 57 && *ptr < 65 ) ||
           ( *ptr > 90 && *ptr < 95 ) ||
           ( *ptr > 95 && *ptr < 97 ))
         {
            fprintf( stderr, "%s: non-symbol character in argument.\n",
                     syntax );
            return 1;
         }

   stack_push( stack, make_atom_from_symbol( car->data.atom->data.string->string ));

   return 0;
}

int do_additive( char *syntax, struct object *args, int multiply )
{
   struct object *ptr, *result;
   int i, total;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   total = multiply;
   i = 1;

   for( ptr = args; ptr != NULL; ptr = ptr->next )
   {
      stack_push( stack, ptr );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, i, -1 );
         return 1;
      }

      result = stack_pop( stack );

      if ( islist( result->flags ) == 1 ||
           numberp( result->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, i, ERR_FIXNUM );
         return 1;
      }

      if ( multiply )
         total *= number( result->data.atom );
      else
         total += number( result->data.atom );

      ++i;
   }

   stack_push( stack, make_atom_from_number( total ));

   return 0;
}

int do_add( char *syntax, struct object *args )
{
   return do_additive( syntax, args, 0 );
}

int do_multiply( char *syntax, struct object *args )
{
   return do_additive( syntax, args, 1 );
}

int do_subtractive( char *syntax, struct object *args, int divide )
{
   struct object *car1, *car2;
   int i1, i2, result = 0;

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   i1 = number( car1->data.atom );
   i2 = number( car2->data.atom );

   if ( divide && ! i2 )
   {
      fprintf( stderr, "%s: attempted division by zero.\n", syntax );
      return 1;
   }

   switch( divide )
   {
      case 0:
         result = i1 - i2;
         break;

      case 1:
         result = i1 / i2;
         break;

      case 2:
         result = i1 - ( i2 * ( i1 / i2 ));
   }

   stack_push( stack, make_atom_from_number( result ));

   return 0;
}

int do_subtract( char *syntax, struct object *args )
{
   return do_subtractive( syntax, args, 0 );
}

int do_divide( char *syntax, struct object *args )
{
   return do_subtractive( syntax, args, 1 );
}

int do_modulo( char *syntax, struct object *args )
{
   return do_subtractive( syntax, args, 2 );
}

int do_comparative( char *syntax, struct object *args, int what )
{
   int result = 0, i1, i2;
   struct object *car1, *car2;

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   i1 = number( car1->data.atom );
   i2 = number( car2->data.atom );

   switch( what )
   {
      case 0:
         result = ( i1 > i2 );
         break;

      case 1:
         result = ( i1 >= i2 );
         break;

      case 2:
         result = ( i1 < i2 );
         break;

      case 3:
         result = ( i1 <= i2 );
   }

   stack_push( stack, make_atom_from_number( result ));

   return 0;
}

int do_lesser( char *syntax, struct object *args )
{
   return do_comparative( syntax, args, 2 );
}

int do_lesser_or_eq( char *syntax, struct object *args )
{
   return do_comparative( syntax, args, 3 );
}

int do_greater( char *syntax, struct object *args )
{
   return do_comparative( syntax, args, 0 );
}

int do_greater_or_eq( char *syntax, struct object *args )
{
   return do_comparative( syntax, args, 1 );
}

int do_abs( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   stack_push( stack, make_atom_from_number( abs( number( car->data.atom ))));

   return 0;
}

int do_char( char *syntax, struct object *args )
{
   struct object *car;
   char s[ 2 ];
   int i;

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   i = number( car->data.atom );

   if ( i < 0 || i > 255 )
   {
      fprintf( stderr, "%s: argument out of range: %d\n",
               syntax, i );
      return 1;
   }

   s[ 0 ] = ( char )i;
   s[ 1 ] = '\0';

   stack_push( stack, make_atom_from_string( s, 1 ));

   return 0;
}

int do_code( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   if ( car->data.atom->data.string->length == 0 )
   {
      fprintf( stderr, "%s: argument is empty string.\n", syntax );
      return 1;
   }

   stack_push( stack,
      make_atom_from_number( ( unsigned char)car->data.atom->data.string->string[ 0 ] ));

   return 0;
}

int do_open( char *syntax, struct object *args )
{
   DB *new_db;
   mode_t mode;

   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   mode = getmode( setmode( "0600" ), 0 );

AGAIN:
   if (( new_db = dbopen( NULL, O_EXCL | O_EXLOCK | O_RDWR | O_CREAT, mode,
                          DB_RECNO, NULL )) == NULL )
   {
      if ( errno == EINTR )
         goto AGAIN;

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

   stack_push( buffer_stack, new_db );
   buffer = new_db;

   bookmarks = ( struct hash_elt **)memory( HASH_SIZE * sizeof( struct hash_elt * ));
   bzero( bookmarks, ( HASH_SIZE * sizeof( struct hash_elt * )));

   stack_push( bookmark_stack, bookmarks );

   stack_push( stack, make_atom_from_number( buffer_stack->used - 1 ));

   return 0;
}

int do_close( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer has been opened.\n", syntax );
      return 1;
   }

   if ( buffer->close( buffer ) )
   {
      fprintf( stderr, "%s: db->close: %s", syntax, strerror( errno ));
      return 1;
   }
   else
   {
      int i;

      for( i = 0; i < buffer_stack->used; ++i )
         if ( buffer_stack->values[ i ] == buffer )
         {
            buffer_stack->values[ i ] = NULL;
            hash_free( bookmark_stack->values[ i ] );
            free( bookmark_stack->values[ i ] );
            bookmark_stack->values[ i ] = NULL;
            break;
         }

      buffer = NULL;

      for( i = buffer_stack->used - 1; i >= 0; --i )
      {
         buffer = ( DB *)buffer_stack->values[ i ];
         if ( buffer != NULL )
         {
            bookmarks = bookmark_stack->values[ i ];
            break;
         }
      }

      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_insert( char *syntax, struct object *args )
{
   struct object *car1, *car2, *car3;
   int arg3, flag = 0, real_line;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)3 );

   if ( check_args( syntax, args ))
      return 1;

   car3 = stack_pop( stack );
   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   key_data = number( car1->data.atom );
   real_line = key_data;

   if ( key_data < 0 )
   {
      fprintf( stderr, "%s: argument 1 < 0.\n", syntax );
      return 1;
   }

   arg3 = number( car3->data.atom );

   if ( arg3 == 0 )
      flag = R_SETCURSOR;
   else if ( arg3 > 0 )
   {
      flag = R_IAFTER;
      real_line += 1;
   }
   else if ( arg3 < 0 )
   {
      flag = R_IBEFORE;
      real_line -= 1;
   }

   dbt_key.data = &key_data;
   dbt_key.size = sizeof( recno_t );

   dbt_value.data = car2->data.atom->data.string->string;
   dbt_value.size = car2->data.atom->data.string->length + 1;

   if ( buffer->put( buffer, &dbt_key, &dbt_value, flag ) < 0 )
   {
      fprintf( stderr, "%s: db->put: %s.\n", syntax, strerror( errno ));
      return 1;
   }
   else
      stack_push( stack, make_atom_from_number( 1 ));

   if ( real_line == key_data )
      delete_bookmarks( real_line, real_line );
   else
      adjust_bookmarks( real_line, 1 );

   return 0;
}

int do_delete( char *syntax, struct object *args )
{
   struct object *car;
   int result, arg1;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   arg1 = number( car->data.atom );

   dbt_key.data = &key_data;
   dbt_key.size = sizeof( recno_t );
   key_data = arg1;

   if (( result = buffer->del( buffer, &dbt_key, 0 )) < 0 )
   {
      fprintf( stderr, "%s: delete: db->del: %s.\n", syntax, strerror( errno ));
      stack_push( stack, make_atom_from_number( 0 ));
      return 1;
   }
   else if ( result )
   {
      fprintf( stderr, "%s: index does not exist: %d.\n", syntax,
               key_data );
      stack_push( stack, make_atom_from_number( 0 ));
      return 1;
   }

   delete_bookmarks( key_data, key_data );
   adjust_bookmarks( key_data, -1 );

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_lastline( char *syntax, struct object *args )
{
   int result;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   dbt_key.data = &key_data;
   dbt_key.size = sizeof( recno_t );

   if (( result = buffer->seq( buffer, &dbt_key, &dbt_value, R_LAST )) == -1 )
   {
      fprintf( stderr, "%s: db->seq: %s.\n", syntax, strerror( errno ));
      stack_push( stack, make_atom_from_number( 0 ));
   }
   else if ( result == 1 )
      stack_push( stack, make_atom_from_number( 0 ));
   else
      stack_push( stack, make_atom_from_number( *( int *)dbt_key.data ));

   return 0;
}

int do_retrieve( char *syntax, struct object *args )
{
   struct object *car;
   int result;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   key_data = number( car->data.atom );

   if ( key_data <= 0 )
   {
      fprintf( stderr, "%s: index <= 0.\n", syntax );
      return 1;
   }

   dbt_key.data = &key_data;
   dbt_key.size = sizeof( recno_t );

   if (( result = buffer->get( buffer, &dbt_key, &dbt_value, 0 )) < 0 )
   {
      fprintf( stderr, "%s: db->get: %s.\n", syntax, strerror( errno ));
      return 1;
   }
   else if ( result == 1 )
   {
      fprintf( stderr, "%s: db->get: key does not exist.\n", syntax );
      return 1;
   }

   stack_push( stack, make_atom_from_string( dbt_value.data, dbt_value.size - 1 ));

   return 0;
}

int exchange_data( char *syntax, int fd, int begin, int end, int pid )
{
   struct string *s;
   char *ptr = NULL;
   int i, j, before, out, result, flags;
   fd_set in_set, out_set;

   s = make_string();
   j = end;
   i = begin;
   before = end;

   if ( end )
      out = 1;
   else
   {
      j = begin;
      before = begin;
      shutdown( fd, SHUT_WR );
      out = 0;
   }

   if (( flags = fcntl( fd, F_GETFL, 0 ) ) < 0 )
   {
      fprintf( stderr, "%s: fcntl(): %s.\n", syntax, strerror( errno ));
      return 1;
   }

   if ( fcntl( fd, F_SETFL, flags | O_NONBLOCK ) < 0 )
   {
      fprintf( stderr, "%s: fcntl(): %s.\n", syntax, strerror( errno ));
      return 1;
   }

   for( ; ; )
   {
      char c[ 128 ];

      FD_ZERO( &in_set );
      FD_ZERO( &out_set );

      FD_SET( fd, &in_set );
      if ( out )
         FD_SET( fd, &out_set );

      result = select( fd + 1, &in_set, &out_set, NULL, NULL );

      if ( result < 0 )
      {
         if ( errno == EINTR || errno == EWOULDBLOCK )
            continue;

         ( out ? close( fd ) : shutdown( fd, SHUT_RD ) );
         string_free( s );

         fprintf( stderr, "%s: select: %s.\n", syntax, strerror( errno ));
         return 1;
      }

      if ( FD_ISSET( fd, &in_set ))
      {
         result = read( fd, c, sizeof( c ) - 1 );

         if ( result < 0 )
         {
            if ( errno == EINTR || errno == EWOULDBLOCK )
               continue;

            ( out ? close( fd ) : shutdown( fd, SHUT_RD ) );
            string_free( s );

            fprintf( stderr, "%s: read: %s.\n", syntax, strerror( errno ));
            return 1;
         }
         else if ( result == 0 )
         {
            ( out ?  close( fd ) : shutdown( fd, SHUT_RD ));
            break;
         }
         else
         {
            char *ptr2;

            c[ result ] = '\0';

            for( ptr2 = c; *ptr2; ++ptr2 )
               if ( *ptr2 == '\n' )
               {
                  string_append( s, *ptr2 );

                  key_data = j++;
                  dbt_key.data = &key_data;
                  dbt_key.size = sizeof( recno_t );

                  dbt_value.data = s->str;
                  dbt_value.size = s->used + 1;

                  if ( buffer->put( buffer, &dbt_key, &dbt_value, R_IAFTER ) < 0 )
                  {
                     fprintf( stderr, "%s: db->put: %s.\n", syntax, strerror( errno ));
                     string_free( s );

                     ( out ? close( fd ) : shutdown( fd, SHUT_RD ));
                     return 1;
                  }

                  string_truncate( s );
               }
               else
                  string_append( s, *ptr2 );
         }
      }

      if ( out && FD_ISSET( fd, &out_set ))
      {
         if ( ptr == NULL || *ptr == '\0' )
         {
            dbt_key.data = &key_data;
            dbt_key.size = sizeof( recno_t );
            key_data = i++;

            if (( result = buffer->get( buffer, &dbt_key, &dbt_value, 0 )) < 0 )
            {
               ( out ? close( fd ) : shutdown( fd, SHUT_RD ));
               string_free( s );

               fprintf( stderr, "%s: db->get: %s.\n", syntax, strerror( errno ));
               return 1;
            }
            else if ( result == 1 )
            {
               ( out ? close( fd ) : shutdown( fd, SHUT_RD ));
               string_free( s );

               fprintf( stderr, "%s: db->get: key does not exist.\n", syntax );
               return 1;
            }

            ptr = dbt_value.data;
         }

         result = write( fd, ptr, strlen( ptr ));

         if ( result < 0 )
         {
            if ( errno == EINTR || errno == EWOULDBLOCK )
               continue;

            close( fd );
            string_free( s );

            fprintf( stderr, "%s: write: %s.\n", syntax, strerror( errno ));
            return 1;
         }

         ptr += result;

         if ( *ptr == '\0' )
         {
            if ( i > end )
            {
               shutdown( fd, SHUT_WR );
               ptr = NULL;
               out = 0;
            }
         }
      }
   }

   if ( s->used )
   {
      key_data = j++;
      dbt_key.data = &key_data;
      dbt_key.size = sizeof( recno_t );

      dbt_value.data = s->str;
      dbt_value.size = s->used + 1;

      if ( buffer->put( buffer, &dbt_key, &dbt_value, R_IAFTER ) < 0 )
      {
         fprintf( stderr, "%s: db->put: %s.\n", syntax, strerror( errno ));
         string_free( s );
         return 1;
      }
   }

   waitpid( pid, NULL, 0 );

   string_free( s );

   if ( end && j > end )
   {
      delete_bookmarks( begin, end );
      adjust_bookmarks( end, ( begin - end ) - 1 );
   }

   if ( j > end )
      adjust_bookmarks( ( end ? begin : begin - 1 ), j - end );

   if ( end && j > end )
   {
      for( i = begin; i <= end; ++i )
      {
         key_data = begin;
         dbt_key.data = &key_data;
         dbt_key.size = sizeof( recno_t );

         if ( buffer->del( buffer, &dbt_key, 0 ))
         {
            fprintf( stderr, "%s: db->del: %s.\n", syntax, strerror( errno ));
            return 1;
         }
      }
   }

   stack_push( stack, make_atom_from_number( j - before ));

   return 0;
}

int do_filter( char *syntax, struct object *args )
{
   struct object *car1, *car2, *car3;
   char *exec_args[ 4 ];
   int pid, beginning, ending, result;
   int fd[ 2 ];

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)3 );

   if ( check_args( syntax, args ))
      return 1;

   car3 = stack_pop( stack );
   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   beginning = number( car1->data.atom );
   ending = number( car2->data.atom );

   if ( beginning > ending )
   {
      int temp = beginning;
      beginning = ending;
      ending = temp;
   }

   exec_args[ 0 ] = "/bin/sh";
   exec_args[ 1 ] = "-c";
   exec_args[ 2 ] = car3->data.atom->data.string->string;
   exec_args[ 3 ] = NULL;

   if ( socketpair( PF_LOCAL, SOCK_STREAM, 0, fd ))
   {
      fprintf( stderr, "%s: socketpair: %s.\n", syntax, strerror( errno ));
      return 1;
   }

   switch( pid = fork() )
   {
      case -1:
         fprintf( stderr, "%s: fork: %s.\n", syntax, strerror( errno ));
         return 1;

      case 0:
         if ( dup2( fd[ 0 ], 0 ) < 0 ||
              dup2( fd[ 0 ], 1 ) < 0 )
         {
            fprintf( stderr, "%s (child): dup2: %s.\n", syntax, strerror( errno ));
            _exit( 1 );
         }

         close( fd[ 0 ] );
         close( fd[ 1 ] );

         execv( exec_args[ 0 ], exec_args );
         _exit( 1 );

      default:
         close( fd[ 0 ] );
   }

   result = exchange_data( syntax, fd[ 1 ], beginning, ending, pid );

   return result;
}

int do_write( char *syntax, struct object *args )
{
   struct object *car1, *car2, *car3, *car4, *car5;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   car1 = args;
   car2 = car1->next;

   if ( car2 == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 2, -1 );
      return 1;
   }

   car3 = car2->next;

   if ( car3 == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 3, -1 );
      return 1;
   }

   car4 = car3->next;

   if ( car4 == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 4, -1 );
      return 1;
   }

   car5 = car4->next;

   if ( car5 != NULL && car5->next != NULL )
   {
      print_err( ERR_MORE_ARGS, syntax, 5, -1 );
      return 1;
   }

   stack_push( stack, car1 );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, -1 );
      return 1;
   }

   stack_push( stack, car2 );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 2, -1 );
      return 1;
   }

   stack_push( stack, car3 );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 3, -1 );
      return 1;
   }

   stack_push( stack, car4 );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 4, -1 );
      return 1;
   }

   if ( car5 != NULL )
   {
      stack_push( stack, car5 );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 5, -1 );
         return 1;
      }

      car5 = stack_pop( stack );

      if ( islist( car5->flags ) == 1 ||
           numberp( car5->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 5, ERR_FIXNUM );
         return 1;
      }
   }

   car4 = stack_pop( stack );

   if ( islist( car4->flags ) == 1 ||
        numberp( car4->flags ) == 0 )
   {
      print_err( ERR_ARG_TYPE, syntax, 4, -1 );
      return 1;
   }

   car3 = stack_pop( stack );

   if ( islist( car3->flags ) == 1 ||
        numberp( car3->flags ) ||
        type( car3->data.atom->flags ) != ATOM_STRING )
   {
      print_err( ERR_ARG_TYPE, syntax, 3, -1 );
      return 1;
   }

   car2 = stack_pop( stack );

   if ( islist( car2->flags ) == 1 ||
        numberp( car2->flags ) == 0 )
   {
      print_err( ERR_ARG_TYPE, syntax, 2, -1 );
      return 1;
   }

   car1 = stack_pop( stack );

   if ( islist( car1->flags ) == 1 ||
        numberp( car1->flags ) == 0 )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, -1 );
      return 1;
   }

   {
      char *name, *ptr;
      mode_t mode;
      int arg1, arg2, fd, i, flags, result, escape, create_empty;

      arg1 = number( car1->data.atom );
      arg2 = number( car2->data.atom );

      create_empty = 0;

      if ( !arg1 && !arg2 )
         create_empty = 1;

      escape = 0;
      name = car3->data.atom->data.string->string;

      for( ptr = name; *ptr; ++ptr )
      {
         if ( *ptr == '\\' )
         {
            escape ^= 1;
            continue;
         }

         if ( escape && ( *ptr == 'b' || *ptr == 't' ))
         {
            char *d = ptr;

            *( ptr - 1) = ( *ptr == 't' ? '\t' : ' ' );
            ++ptr;
            bcopy( ptr, d, strlen( ptr ) + 1 );
            ptr -= 2;
         }

         escape = 0;
      }

      if ( car5 == NULL || number( car5->data.atom ) == 0 )
         flags = ( O_CREAT | O_WRONLY );
      else
         flags = ( O_CREAT | O_APPEND | O_WRONLY );

      if ( number( car4->data.atom ) == 1 )
         flags |= O_EXLOCK | O_NONBLOCK;

      mode = getmode( setmode( "0600" ), 0 );

   AGAIN:
      if (( fd = open( name, flags, mode )) < 0 )
      {
         if ( errno == EINTR )
            goto AGAIN;

         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 0;
      }

      /*
       * Truncation must performed AFTER opening the file, because if
       * specified by the O_TRUNC flag to open(), the file will be cleared,
       * even if the function fails due to the existence of an exclusive
       * lock for the file.  This is correct, but stupid, UNIX semantics.
       */

      if ( car5 == NULL || number( car5->data.atom ) == 0 )
         if ( ftruncate( fd, 0 ))
         {
            close( fd );
            stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
            return 0;
         }

      if ( create_empty )
         stack_push( stack, make_atom_from_number( 0 ));
      else
      {
         char output_buffer[ 102400 ], *ptr;
         int room = sizeof( output_buffer );

         if ( arg1 > arg2 )
         {
            int tmp;

            tmp = arg1;
            arg1 = arg2;
            arg2 = tmp;
         }

         ptr = output_buffer;

         for( i = arg1; i <= arg2; ++i )
         {
            dbt_key.data = &key_data;
            dbt_key.size = sizeof( recno_t );
            key_data = i;

            if (( result = buffer->get( buffer, &dbt_key, &dbt_value, 0 )) < 0 )
            {
               close( fd );
               stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
               return 0;
            }
            else if ( result == 1 )
            {
               close( fd );
               stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
               return 0;
            }

            if (( room - ( int )( dbt_value.size - 1 )) < 0 )
            {
               if ( write( fd, output_buffer, ptr - output_buffer ) < 0 )
               {
                  close( fd );
                  stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
                  return 0;
               }

               ptr = output_buffer;
               room = sizeof( output_buffer );
            }

            bcopy( dbt_value.data, ptr, dbt_value.size - 1 );
            ptr += dbt_value.size - 1;
            room -= dbt_value.size - 1;
         }

         if ( write( fd, output_buffer, ptr - output_buffer ) < 0 )
         {
            close( fd );
            stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
            return 0;
         }

         stack_push( stack, make_atom_from_number( arg2 - arg1 + 1 ));
      }

      close( fd );
   }

   return 0;
}

int do_read( char *syntax, struct object *args )
{
   struct object *car1, *car2;
   struct string *s;
   int fd, arg1, i, escape, flags, count = 0, altered = 0;
   char *name, *ptr;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   arg1 = number( car1->data.atom );

   dbt_key.data = &key_data;
   dbt_key.size = sizeof( recno_t );

   if ( buffer->seq( buffer, &dbt_key, &dbt_value, R_LAST ) == -1 )
   {
      fprintf( stderr, "%s: db->seq: %s.\n", syntax, strerror( errno ));
      stack_push( stack, make_atom_from_number( 0 ));
   }

   if ( *( int *)dbt_key.data )
   {
      if ( arg1 )
      {
         flags = R_IAFTER;
         altered = arg1;
      }
      else
      {
         flags = R_IBEFORE;
         altered = 0;
      }
   }
   else
      flags = R_SETCURSOR;

   key_data = ( arg1 ? arg1 : 1 );

   name = car2->data.atom->data.string->string;

   escape = 0;

   for( ptr = name; *ptr; ++ptr )
   {
      if ( *ptr == '\\' )
      {
         escape ^= 1;
         continue;
      }

      if ( escape && ( *ptr == 'b' || *ptr == 't' ))
      {
         char *d = ptr;
         *( ptr - 1) = ( *ptr == 't' ? '\t' : ' ' );
         ++ptr;
         bcopy( ptr, d, strlen( ptr ) + 1 );
         ptr -= 2;
      }

      escape = 0;
   }

AGAIN:
   if (( fd = open( name, O_RDONLY )) < 0 )
   {
      if ( errno == EINTR )
         goto AGAIN;

      switch( errno )
      {
         case ENOENT:
            stack_push( stack, make_atom_from_number( -1 ));
            break;

         case EACCES:
            stack_push( stack, make_atom_from_number( -2 ));
            break;

         default:
            stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
            break;
      }

      return 0;
   }

   s = make_string();

   for( i = 0; ; ++i )
   {
      int result;
      char *ptr;
      char input_buffer[ 102400 ];

   READ:
      result = read( fd, input_buffer, sizeof( input_buffer ) - 1 );

      if ( result < 0 )
      {
         fprintf( stderr, "%s: read: %s.\n", syntax, strerror( errno ));
         break;
      }
      else if ( result == 0 )
      {
         if ( !count && s->used )
            ++count;

         if ( s->used )
         {
            dbt_value.data = s->str;
            dbt_value.size = s->used + 1;

            dbt_key.data = &key_data;
            dbt_key.size = sizeof( recno_t );

            if ( buffer->put( buffer, &dbt_key, &dbt_value, flags ) < 0 )
            {
               fprintf( stderr, "%s: db->put: %s.\n", syntax,
                        strerror( errno ));
               string_free( s );
               close( fd );
               return 1;
            }
         }

         break;
      }
      else
         input_buffer[ result ] = '\0';

      ptr = input_buffer;

      do
      {
         char *ptr2, *tmp;

         ptr2 = ptr;

         if (( ptr = strchr( ptr, '\n' )) == NULL )
         {
            tmp = ptr2;
            while( *tmp )
               string_append( s, *tmp++ );
            goto READ;
         }

         *ptr = '\0';

         tmp = ptr2;
         while( *tmp )
            string_append( s, *tmp++ );
         string_append( s, '\n' );

         dbt_value.data = s->str;
         dbt_value.size = s->used + 1;

         dbt_key.data = &key_data;
         dbt_key.size = sizeof( recno_t );

         if ( buffer->put( buffer, &dbt_key, &dbt_value, flags ) < 0 )
         {
            fprintf( stderr, "%s: db->put: %s.\n", syntax,
                     strerror( errno ));
            string_free( s );
            close( fd );
            return 1;
         }

         string_truncate( s );

         ++count;
         ++key_data;
      }
      while( *++ptr );
   }

   string_free( s );
   close( fd );
   adjust_bookmarks( altered, count );

   stack_push( stack, make_atom_from_number( count ));

   return 0;
}

int do_empty( char *syntax, struct object *args )
{
   int i, last;
   struct stack *keys;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   dbt_key.data = &key_data;
   dbt_key.size = sizeof( recno_t );

   if (( i = buffer->seq( buffer, &dbt_key, &dbt_value, R_LAST )) == 1 )
   {
      stack_push( stack, make_atom_from_number( 0 ));
      return 0;
   }
   else if ( i < 0 )
   {
      fprintf( stderr, "%s: db->seq: %s.\n", syntax, strerror( errno ));
      return 1;
   }

   last = *( int *)dbt_key.data;

   if ( last == 0 )
   {
      stack_push( stack, make_atom_from_number( 1 ));
      return 0;
   }

   keys = get_hash_keys( bookmarks );

   for( i = 0; i < keys->used; ++i )
      insert_elt( bookmarks, ( int )keys->values[ i ], ( struct object *)-1 );

   stack_free( keys );

   dbt_key.data = &key_data;
   dbt_key.size = sizeof( recno_t );
   key_data = 1;

   for( i = 1; i <= last; ++i )
   {
      int result;

      if (( result = buffer->del( buffer, &dbt_key, 0 )) < 0 )
      {
         fprintf( stderr, "%s: db->del: %s.\n", syntax, strerror( errno ));
         return 1;
      }
      else if ( result )
      {
         fprintf( stderr, "%s: index does not exist: %d.\n", syntax, i );
         return 1;
      }
   }

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_slice( char *syntax, struct object *args )
{
   struct object *car1, *car2, *car3, *car4, *car5;
   int arg1, arg2, arg3, arg4, arg5;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)5 );

   if ( check_args( syntax, args ))
      return 1;

   car5 = stack_pop( stack );
   car4 = stack_pop( stack );
   car3 = stack_pop( stack );
   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   arg1 = number( car1->data.atom );
   arg2 = number( car2->data.atom );
   arg3 = number( car3->data.atom );
   arg4 = number( car4->data.atom );
   arg5 = number( car5->data.atom );

   if ( arg4 <= 0 )
   {
      fprintf( stderr, "%s: tabsize specifier <= 0.\n", syntax );
      return 1;
   }

   {
      struct string *s = NULL, *e = NULL;
      char *ptr;
      recno_t i;
      int offset, *offsets = NULL, result;

      dbt_key.data = &key_data;
      dbt_key.size = sizeof( recno_t );
      key_data = arg1;

      if (( result = buffer->get( buffer, &dbt_key, &dbt_value, 0 )) < 0 )
      {
         fprintf( stderr, "%s: db->get: %s.\n", syntax, strerror( errno ));
         return 1;
      }
      else if ( result == 1 )
      {
         fprintf( stderr, "%s: db->get: key does not exist.\n", syntax );
         return 1;
      }

      if ( dbt_value.size == 0 )
      {
         if ( arg5 )
         {
            struct object *c1, *c2;

            c1 = make_atom_from_number( 0 );
            c2 = make_atom_from_number( 0 );
            c1->next = c2;
            stack_push( stack, c1 );

            return 0;
         }

         stack_push( stack, make_atom_from_string( "", 0 ));
         return 0;
      }

      if ( arg5 && dbt_value.size > 1 )
         offsets = ( int *)memory( sizeof( int ) * ( dbt_value.size - 1 ));
      else
         s = make_string();

      e = make_string();

      if ( dbt_value.size > 1 )
      {
         ptr = ( char *)dbt_value.data;
         offset = 0;

         for( i = 0; i < dbt_value.size - 1; ++i )
         {
            if ( *ptr == '\t' )
            {
               int spaces;

               spaces = arg4 - ( i + offset ) % arg4;
               offset += spaces - 1;

               if ( !arg5 )
                  while( spaces-- )
                     string_append( e, ' ' );
            }
            else if ( !arg5 )
               string_append( e, *ptr );

            ++ptr;

            if ( arg5 )
               offsets[ i ] = offset;
         }
      }

      if ( arg5 )
      {
         struct object *result;
         int length;

         result = make_object();
         stack_push( stack, result );
         setlist( result->flags );

         length = ( dbt_value.size - 1 ) - arg2;
         if ( arg3 )
            length = MIN( arg3, length );

         result->data.head = make_atom_from_number( length );

         result->data.head->next =
            make_atom_from_number(( length ? offsets[ --length ] : 0 ));

         if ( dbt_value.size > 1 )
            free( offsets );
      }
      else
      {
         if ( arg2 >= e->used )
         {
            stack_push( stack, make_atom_from_string( "", 0 ));
            string_free( s );
            string_free( e );
            return 0;
         }

         ptr = &e->str[ arg2 ];
         if ( arg3 )
            arg3 += arg2;

         result = ( arg3 ? MIN( arg3, e->used ) : e->used );

         for( i = arg2; i < result; ++i )
            string_append( s, *ptr++ );

         stack_push( stack, make_atom_from_string( s->str, s->used ));
         string_free( s );
      }

      string_free( e );
   }

   return 0;
}

int do_find( char *syntax, struct object *args )
{
   struct object *car1, *car2, *car3, *car4, *car5;
   char *old_ptr;
   int limit, last, old_arg3, i, j, flags,
      found, inc, end, start, result, old_result,
      arg1, arg2, arg3, arg5;
   regmatch_t matches, old_matches;
   regex_t *r;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_REGEXP );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)5 );

   if ( check_args( syntax, args ))
      return 1;

   car5 = stack_pop( stack );
   car4 = stack_pop( stack );
   car3 = stack_pop( stack );
   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   arg5 = number( car5->data.atom );
   arg1 = number( car1->data.atom );

   dbt_key.data = &key_data;
   dbt_key.size = sizeof( recno_t );

   if ( buffer->seq( buffer, &dbt_key, &dbt_value, R_LAST ) == -1 )
   {
      fprintf( stderr, "%s: db->seq: %s.\n", syntax, strerror( errno ));
      stack_push( stack, make_atom_from_number( 0 ));
   }

   last = *( int *)dbt_key.data;

   if ( arg1 < 0 )
   {
      end = 0;
      inc = -1;
   }
   else
   {
      end = last + 1;
      inc = 1;
   }

   arg2 = number( car2->data.atom );
   start = arg2;

   arg3 = number( car3->data.atom );

   found = 0;
   limit = arg3;

   r = car4->data.atom->data.regexp;

   for( j = 0; j < 2; ++j )
   {
      for( i = start; i != end; i += inc )
      {
         char *ptr, *temp;

         dbt_key.data = &key_data;
         dbt_key.size = sizeof( recno_t );
         key_data = i;

         if (( result = buffer->get( buffer, &dbt_key, &dbt_value, 0 )) < 0 )
         {
            fprintf( stderr, "%s: db->get: %s.\n",
                     syntax, strerror( errno ));
            return 1;
         }
         else if ( result == 1 )
         {
            fprintf( stderr, "%s: db->get: key does not exist: %d.\n",
                     syntax, i );
            return 1;
         }

         temp = ( char *)dbt_value.data;
         temp = str_dup( temp, dbt_value.size );

         if (( ptr = strchr( temp, '\n' )) != NULL )
            *ptr = '\0';

         ptr = temp;

         if ( i == arg2 &&
            ( arg3 < 0 || ( arg3 && arg3 > dbt_value.size - 2 )))
         {
            fprintf( stderr, "%s: argument 3 out of range.\n", syntax );
            return 1;
         }

         result = REG_NOMATCH;

         arg3 = 0;
         old_ptr = NULL;
         matches.rm_eo = 0;
         flags = 0;

         do
         {
            old_arg3 = arg3;
            arg3 += matches.rm_eo;
            old_result = result;
            old_matches = matches;

            if ( ptr == old_ptr )
               break;

            old_ptr = ptr;

            result = regexec( r, ptr, 1, &matches, flags );

            if ( !result )
            {
               if ( i == arg2 )
               {
                  if (( arg1 < 0 && arg3 + matches.rm_so >= limit ) ||
                      ( arg1 > 0 && arg3 + matches.rm_so > limit ))
                     break;
               }
               else if ( arg1 > 0 )
                  break;

               ptr += matches.rm_eo;
            }

            flags = REG_NOTBOL;
         }
         while( !result );

         free( temp );

         if ( arg1 < 0 )
         {
            result = old_result;
            matches = old_matches;
            arg3 = old_arg3;
         }
         else if ( i == arg2 )
         {
            if ( arg3 + matches.rm_so <= limit )
               continue;

            if ( limit + 1 == dbt_value.size - 1 &&
                 limit + 1 == arg3 + matches.rm_so )
               continue;
         }

         if ( result )
         {
            if ( result == REG_NOMATCH )
               continue;

            {
               char err[ 80 ];

               regerror( result, r, err, sizeof( err ));
               fprintf( stderr, "%s: regexec: %s.\n", syntax, err );
               return 1;
            }
         }

         found = 1;
         goto LIST;
      }

      if ( !arg5 )
         break;

      if ( arg1 > 0 )
      {
         start = 1;
         end = last + 1;
      }
      else
      {
         start = last;
         end = 0;
      }

      arg2 = 0;
   }

LIST:
   car1 = make_object();
   stack_push( stack, car1 );
   setlist( car1->flags );

   if ( !found )
   {
      car1->data.head = make_atom_from_number( 0 );
      car1->data.head->next = make_atom_from_number( 0 );
      car1->data.head->next->next = make_atom_from_number( 0 );
   }
   else
   {
      int len = matches.rm_eo - matches.rm_so;

      if (( i == arg2 && arg1 > 0 ) || arg1 < 0 )
         matches.rm_so += arg3;

      if ( matches.rm_so > 0 && matches.rm_so == dbt_value.size - 1 )
         --matches.rm_so;

      car1->data.head = make_atom_from_number( i );
      car1->data.head->next = make_atom_from_number( matches.rm_so );
      car1->data.head->next->next = make_atom_from_number( len );
   }

   return 0;
}

int do_input( char *syntax, struct object *args )
{
   struct object *car1, *car2;
   int pid, pipe, arg1, last, result, escape;
   char *name, *ptr;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   dbt_key.data = &key_data;
   dbt_key.size = sizeof( recno_t );

   if ( buffer->seq( buffer, &dbt_key, &dbt_value, R_LAST ) == -1 )
   {
      fprintf( stderr, "%s: db->seq: %s.\n", syntax, strerror( errno ));
      stack_push( stack, make_atom_from_number( 0 ));
      return 1;
   }

   last = *( int *)dbt_key.data;

   arg1 = number( car1->data.atom );

   if ( arg1 < 0 || arg1 > last )
   {
      fprintf( stderr, "%s: argument 1 out of range.\n", syntax );
      return 1;
   }

   name = car2->data.atom->data.string->string;
   escape = 0;

   for( ptr = name; *ptr; ++ptr )
   {
      if ( *ptr == '\\' )
      {
         escape ^= 1;
         continue;
      }

      if ( escape && ( *ptr == 'b' || *ptr == 't' ))
      {
         char *d = ptr;
         *( ptr - 1) = ( *ptr == 't' ? '\t' : ' ' );
         ++ptr;
         bcopy( ptr, d, strlen( ptr ) + 1 );
         ptr -= 2;
      }

      escape = 0;
   }

   pipe = pipe_open( syntax, name, 0, 0, &pid );

   if ( pipe == -1 )
   {
      stack_push( stack, make_atom_from_number( 0 ));
      return 0;
   }

   result = exchange_data( syntax, pipe, arg1, 0, pid );

   return result;
}

int do_output( char *syntax, struct object *args )
{
   struct object *car1, *car2, *car3;
   char *name, *ptr;
   int i, result, escape, arg1, arg2, pipe, pid;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)3 );

   if ( check_args( syntax, args ))
      return 1;

   car3 = stack_pop( stack );
   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   arg1 = number( car1->data.atom );
   arg2 = number( car2->data.atom );

   if ( arg1 > arg2 )
   {
      int tmp;

      tmp = arg1;
      arg1 = arg2;
      arg2 = tmp;
   }

   name = car3->data.atom->data.string->string;
   escape = 0;

   for( ptr = name; *ptr; ++ptr )
   {
      if ( *ptr == '\\' )
      {
         escape ^= 1;
         continue;
      }

      if ( escape && ( *ptr == 'b' || *ptr == 't' ))
      {
         char *d = ptr;
         *( ptr - 1) = ( *ptr == 't' ? '\t' : ' ' );
         ++ptr;
         bcopy( ptr, d, strlen( ptr ) + 1 );
         ptr -= 2;
      }

      escape = 0;
   }

   pipe = pipe_open( syntax, name, 1, 0, &pid );

   if ( pipe == -1 )
   {
      stack_push( stack, make_atom_from_number( 0 ));
      return 0;
   }

   for( i = arg1; i <= arg2; ++i )
   {
      int len, written;
      char *current;

      dbt_key.data = &key_data;
      dbt_key.size = sizeof( recno_t );
      key_data = i;

      if (( result = buffer->get( buffer, &dbt_key, &dbt_value, 0 )) < 0 )
      {
         close( pipe );
         waitpid( pid, NULL, 0 );
         fprintf( stderr, "%s: db->get: %s.\n", syntax, strerror( errno ));
         return 1;
      }
      else if ( result == 1 )
      {
         close( pipe );
         waitpid( pid, NULL, 0 );
         fprintf( stderr, "%s: db->get: key does not exist.\n", syntax );
         return 1;
      }

      current = ( char *)dbt_value.data;
      written = 0;

      do
      {
         current += written;
         len = strlen( current );

         if (( written = write( pipe, current, len )) < 0 )
         {
            close( pipe );
            waitpid( pid, NULL, 0 );

            if ( errno == EPIPE )
            {
               stack_push( stack, make_atom_from_number( i - arg1 ));
               return 0;
            }

            fprintf( stderr, "%s: %s.\n", syntax, strerror( errno ));
            return 1;
         }
      }
      while( written < len );
   }

   close( pipe );
   waitpid( pid, NULL, 0 );

   stack_push( stack, make_atom_from_number( i - arg1 ));

   return 0;
}

int do_system( char *syntax, struct object *args )
{
   struct object *car;
   int result;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   if ( blocked )
   {
      do_unblock( syntax, NULL );
      stack_pop( stack );
   }

   car = stack_pop( stack );
   result = system( car->data.atom->data.string->string );

   stack_push( stack, make_atom_from_number( result ));

   if ( blocked )
   {
      do_block( syntax, NULL );
      stack_pop( stack );
   }

   return 0;
}

int do_maxidx( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   stack_push( stack, make_atom_from_number( INT_MAX ));

   return 0;
}

int do_chdir( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   if ( chdir( car->data.atom->data.string->string ))
   {
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return 0;
   }

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_boundp( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)ERR_ATOM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   if ( lookup_local( car->data.atom->id ) == NULL &&
        lookup_binding( car->data.atom->id ) == NULL )
      stack_push( stack, make_atom_from_number( 0 ));
   else
      stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_buffer( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( buffer == NULL )
   {
      stack_push( stack, make_atom_from_number( -1 ));
      return 0;
   }

   {
      int i;

      for( i = 0; i < buffer_stack->used; ++i )
         if ( buffer == buffer_stack->values[ i ] )
            break;

      stack_push( stack, make_atom_from_number( i ));
   }

   return 0;
}

int do_buffers( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object **ptr, *result;
      int i;

      result = make_object();
      setlist( result->flags );
      stack_push( stack, result );

      ptr = &result->data.head;

      for( i = 0; i < buffer_stack->used; ++i )
         if ( buffer_stack->values[ i ] != NULL )
         {
            *ptr = make_atom_from_number( i );
            ptr = &( *ptr )->next;
         }
   }

   return 0;
}

int do_switch( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      int i;

      car = stack_pop( stack );
      i = number( car->data.atom );

      if ( i < 0 )
      {
         fprintf( stderr, "%s: negative buffer number: %d.\n", syntax, i );
         return 1;
      }

      if ( i > buffer_stack->used - 1 ||
           buffer_stack->values[ i ] == NULL )
      {
         fprintf( stderr, "%s: buffer %d is not open.\n", syntax, i );
         return 1;
      }

      buffer = ( DB *)buffer_stack->values[ i ];
      bookmarks = ( struct hash_elt **)bookmark_stack->values[ i ];

      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_version( char *syntax, struct object *args )
{
   struct object *result;

   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   result = make_object();
   setlist( result->flags );
   stack_push( stack, result );

   result->data.head = make_atom_from_number( VERSION_MAJOR );
   result->data.head->next = make_atom_from_number( VERSION_MINOR );

   return 0;
}

int do_gensym( char *syntax, struct object *args )
{
   char name[ 64 ];

   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   snprintf( name, sizeof( name ), "<GENSYM#%d>", gensym_counter++ );
   stack_push( stack, make_atom_from_symbol( name ));

   return 0;
}

int do_libdir( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   stack_push( stack, make_atom_from_string( DATADIR, strlen( DATADIR )));

   return 0;
}

int do_substring( char *syntax, struct object *args )
{
   struct object *car1, *car2, *car3;
   struct string *s;
   char *ptr;
   int arg2, arg3;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)3 );

   if ( check_args( syntax, args ))
      return 1;

   car3 = stack_pop( stack );
   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   arg2 = number( car2->data.atom );
   arg3 = number( car3->data.atom );

   if ( arg2 < 0 )
   {
      fprintf( stderr, "%s: index < 0.\n", syntax );
      return 1;
   }

   if ( arg3 < 0 )
   {
      fprintf( stderr, "%s: length < 0.\n", syntax );
      return 1;
   }

   if ( arg2 >= car1->data.atom->data.string->length )
   {
      fprintf( stderr, "%s: index beyond end of string argument.\n",
               syntax );
      return 1;
   }

   s = make_string();
   ptr = &car1->data.atom->data.string->string[ arg2 ];

   if ( arg3 == 0 || ( arg3 + arg2 ) > car1->data.atom->data.string->length )
      arg3 = car1->data.atom->data.string->length - arg2;

   string_append( s, '"' );

   while( arg3-- )
      string_append( s, *ptr++ );

   stack_push( stack, make_atom_directly_from_string( s->str, s->used ));
   free( s );

   return 0;
}

int do_expand( char *syntax, struct object *args )
{
   struct object *car1, *car2;
   char *ptr;
   int offset = 0, i, len, arg1;
   struct string *s;

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   arg1 = number( car1->data.atom );

   ptr = car2->data.atom->data.string->string;
   len = car2->data.atom->data.string->length;

   s = make_string();

   for( i = 0; i < len; ++i )
   {
      if ( *ptr == '\t' )
      {
         int spaces;

         spaces = arg1 - ( i + offset ) % arg1;
         offset += spaces - 1;

         while( spaces-- )
            string_append( s, ' ' );
      }
      else
         string_append( s, *ptr );

      ++ptr;
   }

   stack_push( stack, make_atom_from_string( s->str, s->used ));
   string_free( s );

   return 0;
}

int do_interact( char *syntax, struct object *args )
{
   int i;

   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( interactive )
   {
      fprintf( stderr, "%s: already running interactively.\n", syntax );
      return 1;
   }

   interactive = 1;
   i = stack->used;

   stack_push( open_envs, local_env );
   local_env = NULL;

   for( ; ; )
   {
      int depth, result;

      if ( mode == 0 )
         canon( syntax );

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

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

      result = evaluate();
      close_descriptors();

      if ( result == 0 )
      {
         if ( printer )
         {
            print_object( *( struct object **)stack->top );
            putchar( '\n' );
         }
      }

      stop = next_iteration = 0;

      if ( thrown != NULL )
      {
         fprintf( stderr, "%s: uncaught \"throw\"\n", syntax );
         thrown = NULL;
      }

      collect_garbage();
   }

   local_env = stack_pop( open_envs );

   stack_truncate( stack, stack->used - i );
   stack_push( stack, make_atom_from_number( 1 ));
   interactive = 0;

   return 0;
}

int do_current( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   stack_push( stack, make_atom_from_string( *arg_ptr, strlen( *arg_ptr )));

   return 0;
}

int do_next( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( arg_ptr < last_arg )
   {
      ++arg_ptr;
      stack_push( stack, make_atom_from_string( *arg_ptr, strlen( *arg_ptr )));
   }
   else
      stack_push( stack, make_atom_from_number( 0 ));

   return 0;
}

int do_prev( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( arg_ptr > first_arg )
   {
      --arg_ptr;
      stack_push( stack, make_atom_from_string( *arg_ptr, strlen( *arg_ptr )));
   }
   else
      stack_push( stack, make_atom_from_number( 0 ));

   return 0;
}

int do_rewind( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   arg_ptr = first_arg;

   stack_push( stack, make_atom_from_string( *arg_ptr, strlen( *arg_ptr )));

   return 0;
}

int do_pwd( char *syntax, struct object *args )
{
   char d[ MAXPATHLEN + 1 ];

   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   getcwd( d, sizeof( d ));

   if ( d == NULL )
   {
      fprintf( stderr, "%s: getcwd(): %s.\n", syntax, strerror( errno ));
      return 1;
   }

   stack_push( stack, make_atom_from_string( d, strlen( d )));

   return 0;
}

int do_exit( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   exit( number( car->data.atom ));

   return 0;
}

struct object *make_atom_from_table( struct hash_elt **table )
{
   struct object *object;
   struct atom *entry;
   char buffer[ 64 ];

   snprintf( buffer, sizeof( buffer ), "<TABLE#%d>", table_counter++ );

   entry = get_id( buffer, strlen( buffer ), 1 );
   entry->flags = ATOM_TABLE;
   entry->data.hash = table;

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

   return object;
}

int do_table( char *syntax, struct object *args )
{
   struct hash_elt **table, **ptr;
   int i;

   stack_push( arg_stack, ( void *) 0 );

   if ( check_args( syntax, args ))
     return 1;

   table = ( struct hash_elt **)memory( sizeof( struct hash_elt *) * HASH_SIZE );

   ptr = table;

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

   stack_push( stack, make_atom_from_table( table ));

   return 0;
}

struct object *make_atom_from_number_for_hash_key( int n )
{
   struct object *obj;
   char buffer[ 64 ];

   snprintf( buffer, sizeof( buffer ), "%i", n );

   obj = make_object();
   obj->data.atom = get_id( buffer, strlen( buffer ), 1 );
   obj->data.atom->flags = ATOM_FIXNUM ;
   obj->data.atom->data.record = ( void *)n;

   return obj;
}

int do_hash( char *syntax, struct object *args )
{
   struct object *car1, *car2, *car3;

   stack_push( arg_stack, ( void *)ERR_TABLE );
   stack_push( arg_stack, ( void *)ERR_ATOM );
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)3 );

   if ( check_args( syntax, args ))
      return 1;

   car3 = stack_pop( stack );
   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   if ( numberp( car2->flags ) )
   {
      struct object *obj;

      obj = make_atom_from_number_for_hash_key( number( car2->data.atom ) );
      insert_elt( car1->data.atom->data.hash, obj->data.atom->id, car3 );
   }
   else
      insert_elt( car1->data.atom->data.hash, car2->data.atom->id, car3 );

   stack_push( stack, car3 );

   return 0;
}

int do_unhash( char *syntax, struct object *args )
{
   struct object *car1, *car2;

   stack_push( arg_stack, ( void *)ERR_TABLE );
   stack_push( arg_stack, ( void *)ERR_ATOM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   if ( numberp( car2->flags ) )
   {
      struct object *obj;

      obj = make_atom_from_number_for_hash_key( number( car2->data.atom ) );
      remove_elt( car1->data.atom->data.hash, obj->data.atom->id );
   }
   else
      remove_elt( car1->data.atom->data.hash, car2->data.atom->id );

   stack_push( stack, car2 );

   return 0;
}

int do_lookup( char *syntax, struct object *args )
{
   struct object *car1, *car2;

   stack_push( arg_stack, ( void *)ERR_TABLE );
   stack_push( arg_stack, ( void *)ERR_ATOM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   if ( numberp( car2->flags ) )
   {
      struct object *obj;

      obj = make_atom_from_number_for_hash_key( number( car2->data.atom ) );
      car1 = lookup_elt( car1->data.atom->data.hash, obj->data.atom->id );
   }
   else
      car1 = lookup_elt( car1->data.atom->data.hash, car2->data.atom->id );

   if ( car1 == NULL )
   {
      stack_push( stack, make_object());
      setlist( ( *( struct object **)stack->top )->flags );
   }
   else
      stack_push( stack, car1 );

   return 0;
}

int do_keys( char *syntax, struct object *args )
{
   struct object *car, **ptr, *result;
   struct stack *keys;
   int idx;

   stack_push( arg_stack, ( void *)ERR_TABLE );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   keys = get_hash_keys( car->data.atom->data.hash );

   result = make_object();
   setlist( result->flags );
   stack_push( stack, result );

   ptr = &result->data.head;

   if ( keys->used == 0 )
      result->data.head = NULL;
   else
   {
      struct atom *entry;

      for( idx = 0; idx < keys->used; ++idx )
      {
         *ptr = make_object();

         entry = lookup_atom( ( int)keys->values[ idx ] );

         if ( type( entry->flags ) == ATOM_FIXNUM )
         {
            setnumber( ( *ptr )->flags );
            ( *ptr )->data.atom = toptr( entry->data.record );
         }
         else
            ( *ptr )->data.atom = entry;

         ptr = &( *ptr )->next;
      }
   }

   stack_free( keys );

   return 0;
}

int do_values( char *syntax, struct object *args )
{
   struct object *car, **ptr, *result;
   struct stack *values;
   int idx;

   stack_push( arg_stack, ( void *)ERR_TABLE );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   values = get_hash_values( car->data.atom->data.hash );

   result = make_object();
   setlist( result->flags );
   stack_push( stack, result );

   ptr = &result->data.head;

   if ( values->used == 0 )
      result->data.head = NULL;
   else
   {
      for( idx = 0; idx < values->used; ++idx )
      {
         *ptr = duplicate_object( ( struct object *)values->values[ idx ] );
         ptr = &( *ptr )->next;
      }
   }

   stack_free( values );

   return 0;
}

int do_redirect( char *syntax, struct object *args )
{
   struct object *car1, *car2, *car3, *car4;
   int flags, fd, arg1;
   mode_t mode;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 1, -1 );
      return 1;
   }

   if ( args->next == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 2, -1 );
      return 1;
   }

   stack_push( stack, args );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, -1 );
      return 1;
   }

   stack_push( stack, args->next );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 2, -1 );
      return 1;
   }

   if ( args->next->next != NULL )
   {
      stack_push( stack, args->next->next );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 3, -1 );
         return 1;
      }

      if ( args->next->next->next != NULL )
      {
         stack_push( stack, args->next->next->next );

         if ( evaluate() )
         {
            if ( !stop )
               print_err( ERR_EVAL, syntax, 4, -1 );
            return 1;
         }

         car4 = stack_pop( stack );

         if ( islist( car4->flags ) || numberp( car4->flags ) == 0 )
         {
            print_err( ERR_ARG_TYPE, syntax, 4, ERR_FIXNUM );
            return 1;
         }

         if ( args->next->next->next->next != NULL )
         {
            print_err( ERR_MORE_ARGS, syntax, 4, -1 );
            return 1;
         }
      }
      else
         car4 = NULL;

      car3 = stack_pop( stack );

      if ( islist( car3->flags ) || numberp( car3->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 3, ERR_FIXNUM );
         return 1;
      }
   }
   else
   {
      car3 = NULL;
      car4 = NULL;
   }

   car2 = stack_pop( stack );

   if ( islist( car2->flags ) ||
        numberp( car2->flags ) ||
        type( car2->data.atom->flags ) != ATOM_STRING )
   {
      print_err( ERR_ARG_TYPE, syntax, 2, ERR_STRING );
      return 1;
   }

   car1 = stack_pop( stack );

   if ( islist( car1->flags ) || numberp( car1->flags ) == 0 )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_FIXNUM );
      return 1;
   }

   arg1 = number( car1->data.atom );

   if ( arg1 < 0 || arg1 > 2 )
   {
      fprintf( stderr, "%s: descriptor %d out of range.\n", syntax, arg1 );
      return 1;
   }

   flags = 0;

   if ( arg1 )
   {
      fflush( ( arg1 == 1 ? stdout : stderr ));
      flags = O_CREAT;

      if ( car3 != NULL && number( car3->data.atom ))
         flags = O_APPEND;
   }

   flags |= ( arg1 ? ( O_WRONLY | O_NONBLOCK ) :
                     ( O_RDONLY | O_NONBLOCK ));

   if ( car4 != NULL && number( car4->data.atom ))
      flags |= ( arg1 ? O_EXLOCK : O_SHLOCK );

   mode = getmode( setmode( "0600" ), 0 );

AGAIN:
   if (( fd = open( car2->data.atom->data.string->string, flags, mode )) < 0 )
   {
      if ( errno == EINTR )
         goto AGAIN;

      switch( errno )
      {
         case ENOENT:
            stack_push( stack, make_atom_from_number( -1 ));
            break;

         case EACCES:
            stack_push( stack, make_atom_from_number( -2 ));
            break;

         case EBUSY:
         case EAGAIN:
            stack_push( stack, make_atom_from_number( -3 ));
            break;

         default:
            stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      }

      return 0;
   }

   if ( arg1 && ( car3 == NULL || number( car3->data.atom ) == 0 ))
      if ( ftruncate( fd, 0 ))
      {
         close( fd );
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 0;
      }

   if (( flags = dup( arg1 )) < 0 )
   {
      close( fd );
      fprintf( stderr, "%s: dup: %s.\n", syntax, strerror( errno ));
      return 1;
   }

   if ( arg1 )
      fclose( (( arg1 == 1 ? stdout : stderr )));

   stack_push( descriptors[ arg1 ], ( void *)flags );

   if ( dup2( fd, arg1 ) < 0 )
   {
      close( fd );
      stack_pop( descriptors[ arg1 ] );
      fprintf( stderr, "%s: dup2: %s.\n", syntax, strerror( errno ));
      return 1;
   }

   close( fd );

   if ( arg1 )
   {
      FILE *file;

      file = fdopen( arg1, ( car3 != NULL && number( car3->data.atom ) ? "a" : "w" ));

      if ( file == NULL )
      {
         fprintf( stderr, "%s: fdopen: %s.\n", syntax, strerror( errno ));
         return 1;
      }

      if ( arg1 == 1 )
         stdout = file;
      else
         stderr = file;
   }
   else
      getline_from_file( syntax, 1 );

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

void resume( char *syntax, int arg1 )
{
   int fd;

   fd = ( int )stack_pop( descriptors[ arg1 ] );

   if ( arg1 )
   {
      if ( arg1 == 1 && stdout != NULL )
         fclose( stdout );
      else if ( arg1 == 2 && stderr != NULL )
         fclose( stderr );
   }

   if ( dup2( fd, arg1 ) < 0 )
   {
      fprintf( stderr, "%s: dup2: %s.\n", syntax, strerror( errno ));
      close( fd );
      return;
   }

   close( fd );

   if ( arg1 == 0 )
      getline_from_file( syntax, 2 );
   else
   {
      if ( arg1 == 1 )
      {
         stdout = fdopen( arg1, "w" );
         if ( stdout == NULL )
         {
            fprintf( stderr, "%s: fdopen: %s.\n", syntax, strerror( errno ));
            return;
         }
      }
      else
      {
         stderr = fdopen( arg1, "w" );
         if ( stderr == NULL )
         {
            fprintf( stdout, "%s: fdopen: %s.\n", syntax, strerror( errno ));
            return;
         }
      }
   }
}

int do_resume( char *syntax, struct object *args )
{
   int arg1;
   struct object *car;

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   arg1 = number( car->data.atom );

   if ( arg1 < 0 || arg1 > 2 )
   {
      fprintf( stderr, "%s: descriptor argument %d out of range.\n", syntax, arg1 );
      return 1;
   }

   if ( descriptors[ arg1 ]->used == 0 )
   {
      stack_push( stack, make_atom_from_number( 0 ));
      return 0;
   }

   resume( syntax, arg1 );
   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_warn( char *syntax, struct object *args )
{
   struct object *ptr;
   int i;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   i = 1;

   for( ptr = args; ptr != NULL; ptr = ptr->next )
   {
      stack_push( stack, ptr );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, i, -1 );
         return 1;
      }

      do_print_objects_strings_unquoted( stack_pop( stack ), 0, 2 );

      ++i;
   }

   fputc( '\n', stderr );

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_getenv( char *syntax, struct object *args )
{
   struct object *car;
   char *p;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   p = getenv( car->data.atom->data.string->string );

   if ( p == NULL )
      stack_push( stack, make_atom_from_number( 0 ));
   else
      stack_push( stack, make_atom_from_string( p, strlen( p )));

   return 0;
}

int do_directory( char *syntax, struct object *args )
{
   struct object *car, **ptr, *result;
   DIR *dir;
   struct dirent *dp;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   if (( dir = opendir( car->data.atom->data.string->string )) == NULL )
   {
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return 0;
   }

   readdir( dir );

   result = make_object();
   setlist( result->flags );
   stack_push( stack, result );

   ptr = &result->data.head;

   while(( dp = readdir( dir )) != NULL )
   {
      *ptr = make_atom_from_string( dp->d_name, dp->d_namlen );
      ptr = &( *ptr )->next;
   }

   closedir( dir );

   return 0;
}

int do_chomp( char *syntax, struct object *args )
{
   struct object *car;
   struct string *s;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   if ( car->data.atom->data.string->length )
   {
      int i;

      s = make_string();
      string_assign( s, car->data.atom->data.string->string,
                        car->data.atom->data.string->length );
      i = s->used;

      while( --i >= 0 )
      {
         if ( s->str[ i ] == '\r' || s->str[ i ] == '\n' )
            string_erase( s, i );
         else
            break;
      }

      stack_push( stack, make_atom_from_string( s->str, s->used ));
      string_free( s );
   }
   else
      stack_push( stack, duplicate_object( car ));

   return 0;
}

int do_chop( char *syntax, struct object *args )
{
   char *new;
   int len;
   struct object *car;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   new = str_dup( car->data.atom->data.string->string,
                  car->data.atom->data.string->length );
   len = car->data.atom->data.string->length;

   if ( len )
   {
      new[ len - 1 ] = '\0';
      stack_push( stack, make_atom_from_string( new, len - 1 ));
   }
   else
      stack_push( stack, duplicate_object( car ));

   free( new );

   return 0;
}

int do_unlink( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   if ( unlink( car->data.atom->data.string->string ))
   {
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return 0;
   }

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_rmdir( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   if ( rmdir( car->data.atom->data.string->string ))
   {
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return 0;
   }

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_rename( char *syntax, struct object *args )
{
   struct object *car1, *car2;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   if ( rename( car1->data.atom->data.string->string,
                car2->data.atom->data.string->string ) < 0 )
   {
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return 0;
   }

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_words( char *syntax, struct object *args )
{
   int i, last, result, flag, total;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   dbt_key.data = &key_data;
   dbt_key.size = sizeof( recno_t );

   if ( buffer->seq( buffer, &dbt_key, &dbt_value, R_LAST ) == -1 )
   {
      fprintf( stderr, "%s: db->seq: %s.\n", syntax, strerror( errno ));
      stack_push( stack, make_atom_from_number( 0 ));
   }

   last = *( int *)dbt_key.data;

   if ( !last )
   {
      stack_push( stack, make_atom_from_number( 0 ));
      return 0;
   }

   total = 0;

   for( i = 1; i <= last; ++i )
   {
      char *ptr;

      dbt_key.data = &key_data;
      dbt_key.size = sizeof( recno_t );
      key_data = i;

      if (( result = buffer->get( buffer, &dbt_key, &dbt_value, 0 )) < 0 )
      {
         fprintf( stderr, "%s: db->get: %s.\n", syntax, strerror( errno ));
         return 1;
      }
      else if ( result == 1 )
      {
         fprintf( stderr, "%s: db->get: key does not exist: %d.\n",
                  syntax, i );
         return 1;
      }

      flag = 0;

      ptr = ( char *)dbt_value.data;

      while( *ptr )
      {
         if ( isspace( *ptr++ ))
         {
            if ( flag )
            {
               ++total;
               flag = 0;
            }

            continue;
         }

         flag = 1;
      }
   }

   stack_push( stack, make_atom_from_number( total ));

   return 0;
}

int do_time( char *syntax, struct object *args )
{
   time_t t;
   char buffer[ 32 ];

   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( time( &t ) < 0 )
   {
      fprintf( stderr, "%s: time(): %s\n.", syntax, strerror( errno ));
      return 1;
   }

   snprintf( buffer, sizeof( buffer ), "%ld", ( long int)t );
   stack_push( stack, make_atom_from_string( buffer, -1 ));

   return 0;
}

int do_random( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *obj;
      float f;
      int r;

      obj = stack_pop( stack );

      if ( number( obj->data.atom ) <= 0 )
      {
         fprintf( stderr, "%s: argument <= 0: %i\n", syntax,
                  number( obj->data.atom ));
         return 1;
      }

      f = random();
      r = number( obj->data.atom ) * f / RAND_MAX;

      stack_push( stack, make_atom_from_number( r ));
   }

   return 0;
}

int do_date( char *syntax, struct object *args )
{
   struct object *car1, *car2;
   time_t t;
   struct tm *lt;
   int gmt = 0, really = 0, len;
   char buffer[ 64 ];

   if ( args != NULL )
   {
      stack_push( stack, args );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 1, -1 );
         return 1;
      }

      if ( args->next != NULL )
      {
         stack_push( stack, args->next );

         if ( evaluate() )
         {
            if ( !stop )
               print_err( ERR_EVAL, syntax, 2, -1 );

            return 1;
         }

         car2 = stack_pop( stack );

         if ( args->next->next )
         {
            print_err( ERR_MORE_ARGS, syntax, 1, -1 );
            return 1;
         }
      }
      else
         car2 = NULL;

      car1 = stack_pop( stack );

      if ( islist( car1->flags ) == 1 || numberp( car1->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 1, ERR_FIXNUM );
         return 1;
      }

      if ( car2 != NULL )
      {
         if ( islist( car2->flags ) == 1 || numberp( car2->flags ) == 0 )
         {
            print_err( ERR_ARG_TYPE, syntax, 2, ERR_FIXNUM );
            return 1;
         }

         really = number( car2->data.atom );
      }

      gmt = number( car1->data.atom );
   }

   if ( time( &t ) < 0 )
   {
      fprintf( stderr, "%s: time(): %s\n.", syntax, strerror( errno ));
      return 1;
   }

   if ( gmt )
   {
      if (( lt = gmtime( &t )) == NULL )
      {
         fprintf( stderr, "%s: gmtime(): %s.\n", syntax, strerror( errno ));
         return 1;
      }
   }
   else
   {
      if (( lt = localtime( &t )) == NULL )
      {
         fprintf( stderr, "%s: localtime(): %s.\n", syntax, strerror( errno ));
         return 1;
      }
   }

   if ( strftime( buffer, sizeof( buffer ) - 1,
                  "%a, %d %b %Y %H:%M:%S %Z",
                  lt ) == 0 )
   {
      fprintf( stderr, "%s: strftime(): %s.\n", syntax, strerror( errno ));
      return 1;
   }

   if ( gmt && really && ( len = strlen( buffer)) > 2 )
   {
      buffer[ --len ] = 'T';
      buffer[ --len ] = 'M';
      buffer[ --len ] = 'G';
   }

   stack_push( stack, make_atom_from_string( buffer, strlen( buffer )));

   return 0;
}

int do_datethen( char *syntax, struct object *args )
{
   struct object *car;
   time_t t;
   struct tm *lt;
   int gmt = 0, i;
   char buffer[ 64 ];

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 1, -1 );
      return 1;
   }

   stack_push( stack, args );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, -1 );
      return 1;
   }

   if ( args->next != NULL )
   {
      stack_push( stack, args->next );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 2, -1 );
         return 1;
      }

      car = stack_pop( stack );

      if ( islist( car->flags ) == 1 || numberp( car->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 2, ERR_FIXNUM );
         return 1;
      }

      if ( args->next->next != NULL )
      {
         print_err( ERR_MORE_ARGS, syntax, 1, -1 );
         return 1;
      }

      gmt = number( car->data.atom );
   }

   car = stack_pop( stack );

   if ( islist( car->flags ) == 1 || numberp( car->flags ))
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_STRING );
      return 1;
   }

   if (( i = atoi( car->data.atom->data.string->string )) < 0 )
   {
      fprintf( stderr, "%s: negative time value supplied.\n", syntax );
      return 1;
   }

   t = i;

   if ( gmt )
   {
      if (( lt = gmtime( &t )) == NULL )
      {
         fprintf( stderr, "%s: gmtime(): %s.\n", syntax, strerror( errno ));
         return 1;
      }
   }
   else
   {
      if (( lt = localtime( &t )) == NULL )
      {
         fprintf( stderr, "%s: localtime(): %s.\n", syntax, strerror( errno ));
         return 1;
      }
   }

   if ( strftime( buffer, sizeof( buffer ) - 1,
                  "%a, %d %b %Y %H:%M:%S %Z",
                  lt ) == 0 )
   {
      fprintf( stderr, "%s: strftime(): %s.\n", syntax, strerror( errno ));
      return 1;
   }

   stack_push( stack, make_atom_from_string( buffer, strlen( buffer )));

   return 0;
}

int do_when( char *syntax, struct object *args )
{
   struct object *cdr, *result;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   cdr = args->next;

   if ( cdr == NULL )
   {
      fprintf( stderr, "%s: missing body expressions.\n", syntax );
      return 1;
   }

   stack_push( stack, args );

   if ( evaluate() )
   {
      if ( !stop )
         fprintf( stderr, "%s: evaluation of test clause failed.\n",
                  syntax );

      return 1;
   }

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

   if ( !(( islist( result->flags ) == 1 && result->data.head == NULL ) ||
            ( islist( result->flags ) == 0 && ( result->data.atom == NULL ||
                                                result->data.atom == empty->data.atom ))))
   {
      stack_pop( stack );

      if ( do_progn( syntax, cdr ) )
      {
         if ( !stop )
            fprintf( stderr, "%s: evaluation of subsequent expressions "
                     "failed.\n", syntax );

         return 1;
      }
   }

   return 0;
}

int do_unless( char *syntax, struct object *args )
{
   struct object *cdr, *result;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   cdr = args->next;

   if ( cdr == NULL )
   {
      fprintf( stderr, "%s: missing body expressions.\n", syntax );
      return 1;
   }

   stack_push( stack, args );

   if ( evaluate() )
   {
      if ( !stop )
         fprintf( stderr, "%s: evaluation of test clause failed.\n",
                  syntax );

      return 1;
   }

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

   if (( islist( result->flags ) == 1 && result->data.head == NULL ) ||
         ( islist( result->flags ) == 0 && ( result->data.atom == NULL ||
                                             result->data.atom == empty->data.atom )))
   {
      stack_pop( stack );

      if ( do_progn( syntax, cdr ) )
      {
         if ( !stop )
            fprintf( stderr, "%s: evaluation of subsequent expressions "
                     "failed.\n", syntax );

         return 1;
      }
   }

   return 0;
}

int do_test( char *syntax, struct object *args )
{
   struct object *result;

   if ( args == NULL || islist( args->flags ) == 0 )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_LIST );
      return 1;
   }

   stack_push( stack, args->data.head );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, 0 );
      return 1;
   }

   result = stack_pop( stack );

   if ( islist( result->flags ) ||
        numberp( result->flags ) ||
        type( result->data.atom->flags ) != ATOM_MACRO )
   {
      fprintf( stderr, "%s: function position did not evaluate"
                       " to a macro closure.\n", syntax );
      return 1;
   }

   return apply_closure( syntax,
                         result->data.atom->data.closure,
                         args->data.head->next,
                         0 );
}

int do_continue( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   stop = 1;
   next_iteration = 1;
   thrown = NULL;

   return 1;
}

int do_block( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

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

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

   blocked = 1;
   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_unblock( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

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

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

   blocked = 0;
   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_exists( char *syntax, struct object *args )
{
   struct object *car;
   struct stat stats;
   int result;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   result = stat( car->data.atom->data.string->string, &stats );

   if ( result < 0 )
   {
      if ( errno == ENOENT )
         stack_push( stack, make_atom_from_number( 0 ));
      else if ( errno == EACCES || errno == ENOTDIR )
         stack_push( stack, make_atom_from_number( -1 ));
      else
      {
         fprintf( stderr, "%s: %s.\n", syntax, strerror( errno ));
         return 1;
      }
   }
   else if ( S_ISREG( stats.st_mode ))
      stack_push( stack, make_atom_from_number( 1 ));
   else if ( S_ISDIR( stats.st_mode ))
      stack_push( stack, make_atom_from_number( 2 ));
   else if ( S_ISCHR( stats.st_mode ))
      stack_push( stack, make_atom_from_number( 3 ));
   else if ( S_ISBLK( stats.st_mode ))
      stack_push( stack, make_atom_from_number( 4 ));
   else if ( S_ISFIFO( stats.st_mode ))
      stack_push( stack, make_atom_from_number( 5 ));
   else if ( S_ISLNK( stats.st_mode ))
      stack_push( stack, make_atom_from_number( 6 ));
   else if ( S_ISSOCK( stats.st_mode ))
      stack_push( stack, make_atom_from_number( 7 ));
   else
      stack_push( stack, make_atom_from_number( 8 ));

   return 0;
}

int do_suspend( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   kill( 0, SIGSTOP );
   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_beep( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   beep();

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_length( char *syntax, struct object *args )
{
   struct object *car, *item;
   int i;

   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );

   i = 0;

   if ( islist( car->flags ))
   {
      for( item = car->data.head; item != NULL; item = item->next )
         ++i;
   }
   else if ( numberp( car->flags ) == 0 &&
             type( car->data.atom->flags ) == ATOM_STRING )
      i = car->data.atom->data.string->length;
   else
   {
      fprintf( stderr, "%s: argument 1 did not evaluate to a string or"
               " a list.\n", syntax );
      return 1;
   }

   stack_push( stack, make_atom_from_number( i ));

   return 0;
}

int do_strcmp( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2;
      int i;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      i = strncmp( car1->data.atom->data.string->string,
                   car2->data.atom->data.string->string,
                   MIN( car1->data.atom->data.string->length,
                        car2->data.atom->data.string->length ) + 1 );

      stack_push( stack, make_atom_from_number( i ));
   }

   return 0;
}

int do_fatal( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   fatal = 1;
   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_nofatal( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   fatal = 0;
   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

#ifdef SQL
int db_busy_handler( void *data, int tries )
{
   struct timespec tv;

   if ( tries == 1000 )
      return 0;

   tv.tv_sec = 0;
   tv.tv_nsec = 250000;

   nanosleep( &tv, NULL );

   return 1;
}

int do_sqlp( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *arg1;

      arg1 = stack_pop( stack );

      if ( islist( arg1->flags ) ||
           numberp( arg1->flags ) ||
           type( arg1->data.atom->flags ) != ATOM_SQL )
         stack_push( stack, make_atom_from_number( 0 ));
      else
         stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_sqlite_open( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      sqlite3 *db;
      const char *sql_err = NULL;

      car = stack_pop( stack );

      if( sqlite3_open( car->data.atom->data.string->string, &db ) != SQLITE_OK )
      {
         sql_err = sqlite3_errmsg( db );
         stack_push( stack, make_atom_from_string( ( char *)sql_err, strlen( sql_err )));
         sqlite3_close( db );
      }
      else
      {
         sqlite3_busy_handler( db, db_busy_handler, NULL );
         stack_push( stack, make_atom_from_db( db ));
      }
   }

   return 0;
}

int do_sqlite_close( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_DB );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;

      car = stack_pop( stack );

      if ( car->data.atom->data.db == NULL )
         stack_push( stack, make_atom_from_number( 0 ));
      else
      {
         sqlite3_close( car->data.atom->data.db );
         car->data.atom->data.db = NULL;
         stack_push( stack, make_atom_from_number( 1 ));
      }
   }

   return 0;
}

int sql_callback( void *data, int total, char **sql_vals, char **sql_cols )
{
   char **ptr;
   struct object **list_ptr;
   int i;

   if ( sql_list == *( struct object **)stack->top )
   {
      list_ptr = &sql_list->data.head;
      *list_ptr = make_object();
      sql_list = *list_ptr;

      setlist( ( *list_ptr )->flags );
      ( *list_ptr )->next = NULL;
      list_ptr = &( *list_ptr )->data.head;

      ptr = sql_cols;

      for( i = 0; i < total; ++i )
      {
         *list_ptr = make_atom_from_string( *ptr, strlen( *ptr ));
         list_ptr = &( *list_ptr )->next;
         *list_ptr = NULL;
         ++ptr;
      }
   }

   list_ptr = &sql_list->next;
   *list_ptr = make_object();
   sql_list = *list_ptr;

   setlist( ( *list_ptr )->flags );
   ( *list_ptr )->next = NULL;
   list_ptr = &( *list_ptr )->data.head;

   ptr = sql_vals;

   for( i = 0; i < total; ++i )
   {
      *list_ptr = make_atom_from_string( *ptr, strlen( *ptr ));
      list_ptr = &( *list_ptr )->next;
      *list_ptr = NULL;

      ++ptr;
   }

   return 0;
}

int do_sqlite_exec( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_DB );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *sql, *db;
      char *sql_err;

      sql = stack_pop( stack );
      db = stack_pop( stack );

      if ( db->data.atom->data.db == NULL )
      {
         stack_push( stack, make_atom_from_string( "database has been closed", 24 ));
         return 1;
      }

      sql_list = make_object();
      setlist( sql_list->flags );
      stack_push( stack, sql_list );

      if ( sqlite3_exec( db->data.atom->data.db,
                         sql->data.atom->data.string->string,
                         sql_callback, NULL, &sql_err )
           != SQLITE_OK )
      {
         stack_pop( stack );
         stack_push( stack, make_atom_from_string( sql_err, strlen( sql_err )));
         free( sql_err );
      }
   }

   return 0;
}

struct object *make_atom_from_prepared_sql( sqlite3_stmt *sql )
{
   struct object *obj;
   struct atom *entry;
   char buffer[ 128 ];

   snprintf( buffer, sizeof( buffer ), "<SQL#%d>", sql_counter++ );
   entry = get_id( buffer, strlen( buffer ), 1 );

   if ( entry->flags == 0 )
   {
      entry->flags = ATOM_SQL;
      entry->data.sql = sql;
   }

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

   return obj;
}

int do_sqlite_prepare( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_DB );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      sqlite3_stmt *compiled;
      const char *ignored;
      struct object *arg1, *arg2;

      arg2 = stack_pop( stack );
      arg1 = stack_pop( stack );

      if ( sqlite3_prepare( arg1->data.atom->data.db,
                            arg2->data.atom->data.string->string,
                            arg2->data.atom->data.string->length,
                            &compiled,
                            &ignored ) != SQLITE_OK )
         stack_push( stack,
            make_atom_from_string(
               ( char *)sqlite3_errmsg( arg1->data.atom->data.db ), -1 ));
      else
         stack_push( stack, make_atom_from_prepared_sql( compiled ));
   }

   return 0;
}

int do_sqlite_bind( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_SQL );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)3 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *arg1, *arg2, *arg3;

      arg3 = stack_pop( stack );
      arg2 = stack_pop( stack );
      arg1 = stack_pop( stack );

      if ( arg1->data.atom->data.sql == NULL )
      {
         fprintf( stderr, "%s: compiled SQL statement has been finalized.\n",
                  syntax );
         return 1;
      }

      if ( sqlite3_bind_text( arg1->data.atom->data.sql,
                              number( arg2->data.atom ),
                              arg3->data.atom->data.string->string,
                              arg3->data.atom->data.string->length,
                              SQLITE_TRANSIENT ) != SQLITE_OK )
         stack_push( stack,
            make_atom_from_string(
               ( char *)sqlite3_errmsg( sqlite3_db_handle( arg1->data.atom->data.sql )),
               -1 ));
      else
         stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_sqlite_step( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_SQL );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *arg;
      int code;

      arg = stack_pop( stack );

      if ( arg->data.atom->data.sql == NULL )
      {
         fprintf( stderr, "%s: compiled SQL statement has been finalized.\n",
                  syntax );
         return 1;
      }

      if (( code = sqlite3_step( arg->data.atom->data.sql )) != SQLITE_ROW )
      {
         if ( code == SQLITE_DONE )
            stack_push( stack, make_atom_from_number( 0 ));
         else
            stack_push( stack,
               make_atom_from_string(
                  ( char *)sqlite3_errmsg( sqlite3_db_handle( arg->data.atom->data.sql )), -1 ));
      }
      else
         stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_sqlite_row( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_SQL );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *arg1, *result, **ptr;
      int total, i, len;
      const char *column;

      arg1 = stack_pop( stack );

      if ( arg1->data.atom->data.sql == NULL )
      {
         fprintf( stderr, "%s: compiled SQL statement has been finalized.\n",
                  syntax );
         return 1;
      }

      total = sqlite3_column_count( arg1->data.atom->data.sql );
      result = make_object();
      setlist( result->flags );

      stack_push( stack, result );

      for( i = 0, ptr = &result->data.head; i < total; ++i, ptr = &( *ptr )->next )
      {
         len = sqlite3_column_bytes( arg1->data.atom->data.sql, i );

         if (( column = sqlite3_column_text( arg1->data.atom->data.sql, i )) == NULL )
         {
            stack_push( stack,
               make_atom_from_string(
                  ( char *)sqlite3_errmsg( sqlite3_db_handle( arg1->data.atom->data.sql )), -1 ));
            return 1;
         }

         *ptr = make_atom_from_string( ( char *)column, len );
      }
   }

   return 0;
}

int do_sqlite_finalize( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_SQL );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *arg1;

      arg1 = stack_pop( stack );

      if ( arg1->data.atom->data.sql == NULL )
      {
         fprintf( stderr, "%s: compiled SQL statement has already been finalized.\n",
                  syntax );
         return 1;
      }

      if ( sqlite3_finalize( arg1->data.atom->data.sql ) != SQLITE_OK )
         stack_push( stack,
            make_atom_from_string(
               ( char *)sqlite3_errmsg( sqlite3_db_handle( arg1->data.atom->data.sql )), -1 ));
      else
      {
         stack_push( stack, make_atom_from_number( 1 ));
         arg1->data.atom->data.sql = NULL;
      }
   }

   return 0;
}

int do_sqlite_reset( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_SQL );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *arg1;

      arg1 = stack_pop( stack );

      if ( arg1->data.atom->data.sql == NULL )
      {
         fprintf( stderr, "%s: compiled SQL statement has been finalized.\n",
                  syntax );
         return 1;
      }

      if ( sqlite3_reset( arg1->data.atom->data.sql ) != SQLITE_OK )
         stack_push( stack,
            make_atom_from_string(
               ( char *)sqlite3_errmsg( sqlite3_db_handle( arg1->data.atom->data.sql )), -1 ));
      else
         stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}
#endif

int do_stack( char *syntax, struct object *args )
{
   struct object *result;
   struct stack *stk;
   int i;

   i = 0;

   if ( args != NULL )
   {
      stack_push( stack, args );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 1, -1 );
         return 1;
      }

      result = stack_pop( stack );

      if ( islist( result->flags ) ||
           numberp( result->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 1, ERR_FIXNUM );
         return 1;
      }

      i = number( result->data.atom );
      result = NULL;

      if ( i < 0 )
      {
         fprintf( stderr, "%s: initialize size < 0: %d.\n", syntax, i );
         return 1;
      }
   }

   stk = make_stack();
   stack_push( stack, make_atom_from_stack( stk ));

   while( i-- )
   {
      struct object *obj;

      obj = make_object();
      setlist( obj->flags );

      stack_push( stk, obj );
   }

   return 0;
}

int do_pop( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STACK );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *obj;
      struct stack *stk;

      obj = stack_pop( stack );
      stk = obj->data.atom->data.stack;
      obj = stack_pop( stk );

      if ( obj == NULL )
      {
         obj = make_object();
         setlist( obj->flags );
      }

      stack_push( stack, obj );
   }

   return 0;
}

int do_push( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STACK );
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      stack_push( car1->data.atom->data.stack, car2 );
      stack_push( stack, car2 );
   }

   return 0;
}

int do_unshift( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STACK );
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      int i;
      struct object *car1, *car2;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      if ( car1->data.atom->data.stack->used )
      {
         stack_push( car1->data.atom->data.stack, NULL );

         for( i = car1->data.atom->data.stack->used - 1; i; --i )
            car1->data.atom->data.stack->values[ i ] =
               car1->data.atom->data.stack->values[ i - 1 ];

         car1->data.atom->data.stack->values[ 0 ] = car2;
      }
      else
         stack_push( car1->data.atom->data.stack, car2 );

      stack_push( stack, car2 );
   }

   return 0;
}

int do_shift( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STACK );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      int i;
      struct object *car, *result;

      car = stack_pop( stack );

      if ( car->data.atom->data.stack->used == 0 )
      {
         result = make_object();
         setlist( result->flags );
      }
      else
      {
         result = car->data.atom->data.stack->values[ 0 ];

         for( i = 0; i < car->data.atom->data.stack->used - 1; ++i )
            car->data.atom->data.stack->values[ i ] =
               car->data.atom->data.stack->values[ i + 1 ];

         stack_pop( car->data.atom->data.stack );
      }

      stack_push( stack, result );
   }

   return 0;
}

int do_used( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STACK );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      struct stack *stk;

      car = stack_pop( stack );
      stk = car->data.atom->data.stack;

      stack_push( stack, make_atom_from_number( stk->used ));
   }

   return 0;
}

int do_index( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STACK );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2;
      struct stack *stk;
      int i;

      car2 = stack_pop( stack );
      i = number( car2->data.atom );

      car1 = stack_pop( stack );
      stk = car1->data.atom->data.stack;

      if ( i < 0 )
      {
         fprintf( stderr, "%s: index < 0: %d.\n", syntax, i );
         return 1;
      }
      else if ( i >= stk->used )
      {
         fprintf( stderr, "%s: index %d out of range.\n", syntax, i );
         return 1;
      }

      stack_push( stack, stk->values[ i ] );
   }

   return 0;
}

int do_store( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STACK );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)3 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2, *car3;
      struct stack *stk;
      int i;

      car3 = stack_pop( stack );

      car2 = stack_pop( stack );
      i = number( car2->data.atom );

      car1 = stack_pop( stack );
      stk = car1->data.atom->data.stack;

      if ( i < 0 || i >= stk->used )
      {
         fprintf( stderr, "%s: index %d out of range.\n", syntax, i );
         return 1;
      }

      stack_push( stack,  stk->values[ i ] = car3 );
   }

   return 0;
}

int do_topidx( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STACK );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      struct stack *stk;

      car = stack_pop( stack );
      stk = car->data.atom->data.stack;

      stack_push( stack, make_atom_from_number( stk->used - 1 ));
   }

   return 0;
}

int do_extract( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_CLOSURE );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *obj, *result;
      char t;

      obj = stack_pop( stack );
      t = type( obj->data.atom->flags );

      result = make_object();
      setlist( result->flags );
      stack_push( stack, result );

      result->data.head = make_object();

      if ( t == ATOM_CLOSURE )
         result->data.head->data.atom = get_id( "lambda", 6, 1 );
      else
         result->data.head->data.atom = get_id( "macro", 5, 1 );

      result->data.head->next = obj->data.atom->data.closure->text;
   }

   return 0;
}

int do_let( char *syntax, struct object *args )
{
   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, 0 );
      return 1;
   }

   if ( islist( args->flags ) == 0 )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_LIST );
      return 1;
   }

   if ( args->data.head == NULL )
   {
      fprintf( stderr, "%s: argument 1 is the empty list.\n",
               syntax );
      return 1;
   }

   if ( args->next == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 2, 0 );
      return 1;
   }

   {
      struct closure *closure;
      struct object *ptr, *sym_list, *arg_list, **ptr2;
      int i;

      sym_list = make_object();
      setlist( sym_list->flags );
      ptr2 = &sym_list->data.head;

      for( i = 1, ptr = args->data.head; ptr!= NULL; ++i, ptr = ptr->next )
      {
         if ( islist( ptr->flags ) == 0 )
         {
            fprintf( stderr, "%s: element %d of argument 1 is not a list.\n",
                     syntax, i );
            return 1;
         }

         if ( ptr->data.head == NULL )
         {
            fprintf( stderr, "%s: element %d of argument 1 is the empty list.\n",
                     syntax, i );
            return 1;
         }

         if ( ptr->data.head->next == NULL )
         {
            fprintf( stderr, "%s: element %d of argument 1 has only one "
                             "sub-element.\n", syntax, i );
            return 1;
         }

         if ( ptr->data.head->next->next != NULL )
         {
            fprintf( stderr, "%s: element %d of argument 1 has more "
                             "than two sub-elements.\n", syntax, i );
            return 1;
         }

         if ( islist( ptr->data.head->flags ) == 1 ||
              numberp( ptr->data.head->flags ) ||
              type( ptr->data.head->data.atom->flags ) != ATOM_SYMBOL )
         {
            fprintf( stderr, "%s: first sub-element of element %d of argument 1"
                             " is not a symbol.\n", syntax, i );
            return 1;
         }

         *ptr2 = make_object();
         ( *ptr2 )->data.atom = ptr->data.head->data.atom;
         ptr2 = &( *ptr2 )->next;
      }

      *ptr2 = NULL;

      arg_list = make_object();
      setlist( arg_list->flags );
      ptr2 = &arg_list->data.head;

      for( ptr = args->data.head; ptr != NULL; ptr = ptr->next )
      {
         *ptr2 = make_object();
         **ptr2 = *ptr->data.head->next;
         ptr2 = &( *ptr2 )->next;
      }

      *ptr2 = NULL;

      sym_list->next = args->next;

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

      stack_push( stack, arg_list );
      stack_push( stack, make_atom_from_closure( closure, 0 ));

      i = apply_closure( syntax, closure, arg_list->data.head, 1 );

      if ( i == 0 )
      {
         ptr = stack_pop( stack );
         stack_pop( stack );
         stack_pop( stack );
         stack_push( stack, ptr );
      }

      return i;
   }
}

int do_letn( char *syntax, struct object *args )
{
   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, 0 );
      return 1;
   }

   if ( islist( args->flags ) == 0 )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_LIST );
      return 1;
   }

   if ( args->data.head == NULL )
   {
      fprintf( stderr, "%s: argument 1 is the empty list.\n",
               syntax );
      return 1;
   }

   if ( args->next == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 2, 0 );
      return 1;
   }

   {
      struct object *result, *ptr, **ptr2, **ptr3;
      int i;

      result = NULL;
      ptr2 = &result;

      for( i = 1, ptr = args->data.head; ptr!= NULL; ++i, ptr = ptr->next )
      {
         if ( islist( ptr->flags ) == 0 )
         {
            fprintf( stderr, "%s: element %d of argument 1 is not a list.\n",
                     syntax, i );
            return 1;
         }

         if ( ptr->data.head == NULL )
         {
            fprintf( stderr, "%s: element %d of argument 1 is the empty list.\n",
                     syntax, i );
            return 1;
         }

         if ( ptr->data.head->next == NULL )
         {
            fprintf( stderr, "%s: element %d of argument 1 has only one "
                             "sub-element.\n", syntax, i );
            return 1;
         }

         if ( ptr->data.head->next->next != NULL )
         {
            fprintf( stderr, "%s: element %d of argument 1 has more "
                             "than two sub-elements.\n", syntax, i );
            return 1;
         }

         if ( numberp( ptr->data.head->flags ) ||
              type( ptr->data.head->data.atom->flags ) != ATOM_SYMBOL )
         {
            fprintf( stderr, "%s: first sub-element of element %d of argument 1"
                             " is not a symbol.\n", syntax, i );
            return 1;
         }

         *ptr2 = make_object();
         setlist( ( *ptr2 )->flags );
         ptr2 = &( *ptr2 )->data.head;

         *ptr2 = make_object();
         ( *ptr2 )->data.atom = get_id( "let", 3, 1 );
         ptr2 = &( *ptr2 )->next;

         *ptr2 = make_object();
         setlist( ( *ptr2 )->flags );
         ptr3 = &( *ptr2 )->next;
         ptr2 = &( *ptr2 )->data.head;

         *ptr2 = make_object();
         setlist( ( *ptr2 )->flags );
         ( *ptr2 )->next = NULL;
         ptr2 = &( *ptr2 )->data.head;

         *ptr2 = ptr->data.head;

         ptr2 = ptr3;
      }

      *ptr2 = args->next;

      stack_push( stack, result );
   }

   return evaluate();
}

int do_labels( char *syntax, struct object *args )
{
   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, 0 );
      return 1;
   }

   if ( islist( args->flags ) == 0 )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_LIST );
      return 1;
   }

   if ( args->data.head == NULL )
   {
      fprintf( stderr, "%s: argument 1 is the empty list.\n",
               syntax );
      return 1;
   }

   if ( args->next == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 2, 0 );
      return 1;
   }

   {
      struct object *ptr, *ptr3, *sym_list, *func_list, **ptr2, *result;
      int i;

      sym_list = make_object();
      setlist( sym_list->flags );
      ptr2 = &sym_list->data.head;

      for( i = 1, ptr = args->data.head; ptr!= NULL; ++i, ptr = ptr->next )
      {
         if ( islist( ptr->flags ) == 0 )
         {
            fprintf( stderr, "%s: element %d of argument 1 is not a list.\n",
                     syntax, i );
            return 1;
         }

         if ( ptr->data.head == NULL )
         {
            fprintf( stderr, "%s: element %d of argument 1 is the empty list.\n",
                     syntax, i );
            return 1;
         }

         if ( ptr->data.head->next == NULL )
         {
            fprintf( stderr, "%s: element %d of argument 1 has only one "
                             "sub-element.\n", syntax, i );
            return 1;
         }

         if ( ptr->data.head->next->next != NULL )
         {
            fprintf( stderr, "%s: element %d of argument 1 has more "
                             "than two sub-elements.\n", syntax, i );
            return 1;
         }

         if ( numberp( ptr->data.head->flags ) ||
              type( ptr->data.head->data.atom->flags ) != ATOM_SYMBOL )
         {
            fprintf( stderr, "%s: first sub-element of element %d of argument 1"
                             " is not a symbol.\n", syntax, i );
            return 1;
         }

         *ptr2 = make_object();
         ( *ptr2 )->data.atom = ptr->data.head->data.atom;
         ptr2 = &( *ptr2 )->next;
      }

      *ptr2 = NULL;

      func_list = make_object();
      setlist( func_list->flags );

      ptr2 = &func_list->data.head;
      ptr3 = sym_list->data.head;

      for( i = 1, ptr = args->data.head; ptr != NULL; ptr = ptr->next, ++i )

      {
         if ( islist( ptr->data.head->next->flags ) == 0 ||
              ptr->data.head->next->data.head == NULL ||
              islist( ptr->data.head->next->data.head->flags ) == 1 ||
              ( ptr->data.head->next->data.head->data.atom->id != lambda_id &&
                ptr->data.head->next->data.head->data.atom->id != macro_id ))
         {
            fprintf( stderr, "%s: second sub-element of element %d of"
                             " argument 1 is not a lambda or macro expression.\n",
                     syntax, i );
            return 1;
         }

         *ptr2 = make_object();

         setlist( ( *ptr2 )->flags );
         ( *ptr2 )->data.head = make_atom_from_symbol( "set" );

         ( *ptr2 )->data.head->next = make_object();
         setlist( ( *ptr2 )->data.head->next->flags );

         ( *ptr2 )->data.head->next->data.head =
            make_atom_from_symbol( "quote" );

         ( *ptr2 )->data.head->next->data.head->next =
            make_atom_from_symbol( ptr3->data.atom->syntax );

         ( *ptr2 )->data.head->next->next = ptr->data.head->next;

         ptr2 = &( *ptr2 )->next;
         ptr3 = ptr3->next;
      }

      *ptr2 = args->next;

      result = make_object();
      setlist( result->flags );
      stack_push( stack, result );

      result->data.head = make_object();
      setlist( result->data.head->flags );

      result->data.head->data.head = make_atom_from_symbol( "lambda" );
      result->data.head->data.head->next = sym_list;
      sym_list->next = func_list->data.head;

      ptr2 = &result->data.head->next;

      for( ptr = args->data.head; ptr != NULL; ptr = ptr->next )
      {
         *ptr2 = make_object();
         setlist( ( *ptr2 )->flags );
         ptr2 = &( *ptr2 )->next;
      }
   }

   return evaluate();
}

int do_cond( char *syntax, struct object *args )
{
   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, 0 );
      return 1;
   }

   {
      struct object *ptr, *result = NULL;
      int i;

      for( i = 1, ptr = args; ptr != NULL; ptr = ptr->next, ++i )
      {
         if ( islist( ptr->flags ) == 0 )
         {
            fprintf( stderr, "%s: argument %d is not a list.\n", syntax, i );
            return 1;
         }

         if ( ptr->data.head == NULL )
         {
            fprintf( stderr, "%s: argument %d is the empty list.\n",
                     syntax, i );
            return 1;
         }

         if ( ptr->data.head->next == NULL )
         {
            fprintf( stderr, "%s: argument %d has only one element.\n",
                     syntax, i );
            return 1;
         }

         stack_push( stack, ptr->data.head );

         if ( evaluate() )
         {
            if ( !stop )
               print_err( ERR_EVAL, syntax, i, 0 );
            return 1;
         }

         result = stack_pop( stack );

         if (( islist( result->flags ) == 1 && result->data.head == NULL ) ||
               result->data.atom == NULL ||
               result->data.atom == empty->data.atom )
            continue;

         if ( do_progn( syntax, ptr->data.head->next ))
         {
            if ( !stop )
               fprintf( stderr, "%s: error evaluating body expression %d.\n",
                        syntax, i );
            return 1;
         }
         else
            return 0;
      }

      stack_push( stack, result );
   }

   return 0;
}

int do_transfer( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)5 );

   if ( check_args( syntax, args ))
      return 1;

   if ( buffer_stack->used == 0 )
   {
      fprintf( stderr, "%s: no buffers have been opened.\n", syntax );
      return 1;
   }

   {
      struct object *obj;
      int bn[ 2 ], f1, t1, t2, j, i, inc;
      DB *bp[ 2 ];

      obj = stack_pop( stack );
      t2 = number( obj->data.atom );

      obj = stack_pop( stack );
      bn[ 1 ] = number( obj->data.atom );

      obj = stack_pop( stack );
      t1 = number( obj->data.atom );

      obj = stack_pop( stack );
      f1 = number( obj->data.atom );

      obj = stack_pop( stack );
      bn[ 0 ] = number( obj->data.atom );

      for( j = 0; j < 2; ++j )
      {
         for( i = 0; i < buffer_stack->used; ++i )
         {
            if ( buffer_stack->values[ i ] != NULL )
            {
               if ( i == bn[ j ] )
                  goto CONT;
            }
         }

         fprintf( stderr, "%s: buffer %d is not open.\n", syntax, bn[ j ] );
         return 1;

      CONT:
         bp[ j ] = buffer_stack->values[ i ];
      }

      dbt_key.data = &key_data;
      dbt_key.size = sizeof( recno_t );

      if (( i = buffer->seq( bp[ 0 ], &dbt_key, &dbt_value, R_LAST )) == -1 )
      {
         fprintf( stderr, "%s: db->seq: %s.\n", syntax, strerror( errno ));
         return 1;
      }
      else if ( i == 1 )
      {
         fprintf( stderr, "%s: buffer %d is empty.\n", syntax, bn[ 0 ] );
         return 1;
      }

      if ( f1 < 1 || f1 > *( int *)dbt_key.data )
      {
         fprintf( stderr, "%s: argument 2 out of range: %d.\n", syntax, f1 );
         return 1;
      }

      if ( t1 < 1 || t1 > *( int *)dbt_key.data )
      {
         fprintf( stderr, "%s: argument 3 out of range: %d.\n", syntax, t1 );
         return 1;
      }

      if (( i = buffer->seq( bp[ 1 ], &dbt_key, &dbt_value, R_LAST )) == -1 )
      {
         fprintf( stderr, "%s: db->seq: %s.\n", syntax, strerror( errno ));
         return 1;
      }
      else if ( i == 1 && t2 != 0 )
      {
         fprintf( stderr, "%s: buffer %d is empty.\n", syntax, bn[ 1 ] );
         return 1;
      }

      if ( t2 < 0 || t2 > *( int *)dbt_key.data )
      {
         fprintf( stderr, "%s: argument 5 out of range: %d.\n", syntax, f1 );
         return 1;
      }

      inc = ( f1 < t1 ? 1 : -1 );

      for( i = f1; ; i += inc )
      {
         key_data = i;
         dbt_key.data = &key_data;
         dbt_key.size = sizeof( recno_t );

         if ( buffer->get( bp[ 0 ], &dbt_key, &dbt_value, 0 ))
         {
            fprintf( stderr, "%s: db->get: %s.\n", syntax, strerror( errno ));
            return 1;
         }

         key_data = t2;

         if ( buffer->put( bp[ 1 ], &dbt_key, &dbt_value, R_IAFTER ))
         {
            fprintf( stderr, "%s: db->put: %s.\n", syntax, strerror( errno ));
            return 1;
         }

         if ( i == t1 )
            break;

         ++t2;
      }

      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int pipe_open( char *syntax, char *task, int wrt, int std, int *rpid )
{
   int fd[ 2 ], pid, flag;
   char *args[ 4 ];

   if ( pipe( &fd[ 0 ] ) < 0 )
   {
      fprintf( stderr, "%s: pipe: %s.\n", syntax, strerror( errno ));
      return -1;
   }

   switch(( pid = fork() ))
   {
      case -1:
         close( fd[ 0 ] );
         close( fd[ 1 ] );
         fprintf( stderr, "%s: fork: %s.\n", syntax, strerror( errno ));
         return -1;

      case 0:
         if (( dup2( fd[ 1 ], !wrt )) < 0 )
         {
            fprintf( stderr, "%s (child): dup2: %s.\n", syntax, strerror( errno ));
            _exit( 1 );
         }

         close( fd[ 0 ] );
         close( fd[ 1 ] );

         args[ 0 ] = "/bin/sh";
         args[ 1 ] = "-c";
         args[ 2 ] = task;
         args[ 3 ] = NULL;

         execv( args[ 0 ], args );
         _exit( 1 );

      default:
         close( fd[ 1 ] );

         if ( std )
         {
            if (( flag = dup( wrt )) < 0 )
            {
               close( fd[ 0 ] );
               fprintf( stderr, "%s: dup: %s.\n", syntax, strerror( errno ));
               return -1;
            }

            stack_push( descriptors[ wrt ], ( void *)flag );

            if ( wrt )
               fclose(( wrt == 1 ? stdout : stderr ));

            if ( dup2( fd[ 0 ], wrt ) < 0 )
            {
               close( fd[ 0 ] );
               close( ( int )stack_pop( descriptors[ wrt ] ));
               fprintf( stderr, "%s: dup2: %s.\n", syntax, strerror( errno ));
               return -1;
            }

            close( fd[ 0 ] );

            if ( wrt == 1 )
            {
               stdout = fdopen( wrt, "w" );
               if ( stdout == NULL )
               {
                  fprintf( stderr, "%s: fdopen: %s.\n", syntax, strerror( errno ));
                  return -1;
               }
            }
            else if ( wrt == 2 )
            {
               stderr = fdopen( wrt, "w" );
               if ( stderr == NULL )
               {
                  fprintf( stdout, "%s: fdopen: %s.\n", syntax, strerror( errno ));
                  return -1;
               }
            }
         }
      }

   if ( rpid != NULL )
      *rpid = pid;

   return ( std ? pid : fd[ 0 ] );
}

int do_pipe( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      int arg1, pid;
      struct object *car1, *car2;

      car1 = stack_pop( stack );
      car2 = stack_pop( stack );
      arg1 = number( car2->data.atom );

      if ( arg1 < 0 || arg1 > 2 )
      {
         fprintf( stderr, "%s: argument 1 out of range: %d.\n", syntax, arg1 );
         return 1;
      }

      pid = pipe_open( syntax, car1->data.atom->data.string->string, arg1, 1, NULL );

      if ( pid == -1 )
      {
         stack_push( stack, make_atom_from_number( 0 ));
         return 0;
      }

      if ( arg1 == 0 )
         getline_from_file( syntax, 1 );

      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_unsetenv( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;

      car = stack_pop( stack );
      unsetenv( car->data.atom->data.string->string );

      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_setenv( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      if ( *car1->data.atom->data.string->string == '\0' )
      {
         fprintf( stderr, "%s: argument 1 is empty string.\n", syntax );
         return 1;
      }

      /*
       * I believe unsetting the variable first avoids the memory leak
       * described in setenv(3).  Am I right?
       */

      unsetenv( car1->data.atom->data.string->string );

      if ( setenv( car1->data.atom->data.string->string,
                   car2->data.atom->data.string->string, 1 ))
      {
         fprintf( stderr, "%s: setenv: %s.\n", syntax, strerror( errno ));
         return 1;
      }

      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int child_open( char *syntax, char *child )
{
   int fd[ 2 ], pid;
   char *args[ 4 ];

   if ( socketpair( PF_UNIX, SOCK_STREAM, 0, &fd[ 0 ] ) < 0 )
   {
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return -1;
   }

   switch(( pid = fork() ))
   {
      case -1:
         close( fd[ 0 ] );
         close( fd[ 1 ] );
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return -1;

      case 0:
         if ( dup2( fd[ 1 ], 0 ) < 0 ||
              dup2( fd[ 1 ], 1 ) < 0 ||
              dup2( fd[ 1 ], 2 ) < 0 )
         {
            fprintf( stderr, "%s (child): dup2: %s.\n", syntax, strerror( errno ));
            _exit( 1 );
         }

         close( fd[ 0 ] );
         close( fd[ 1 ] );

         args[ 0 ] = "/bin/sh";
         args[ 1 ] = "-c";
         args[ 2 ] = child;
         args[ 3 ] = NULL;

         execvp( args[ 0 ], args );
         _exit( 1 );

      default:
         close( fd[ 1 ] );
         child_pid = pid;
   }

   stack_push( stack, make_atom_from_number( 1 ));

   return fd[ 0 ];
}

int open_remote( char *name, int port )
{
   int fd;
   struct sockaddr_in serv_addr;
   struct hostent *host;

   fd = socket( PF_INET, SOCK_STREAM, 0 );

   if ( fd == -1 )
   {
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return -1;
   }

   bzero( &serv_addr, sizeof( serv_addr ));

   serv_addr.sin_family = AF_INET;
   serv_addr.sin_port = htons( port );

   host = gethostbyname( name );

   if ( host == NULL )
   {
      stack_push( stack, make_atom_from_string( ( char *)hstrerror( h_errno ), -1 ));
      return -1;
   }

   memcpy( &serv_addr.sin_addr, *host->h_addr_list, sizeof( struct in_addr ));

   if ( connect( fd, ( struct sockaddr *)&serv_addr, sizeof( serv_addr )) == -1 )
   {
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return -1;
   }

   child_pid = -2;
   stack_push( stack, make_atom_from_number( 1 ));

   return fd;
}

int do_child_open( char *syntax, struct object *args )
{
   int remote;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   remote = 0;

   if ( args->next != NULL )
   {
      if ( args->next->next != NULL )
      {
         print_err( ERR_MORE_ARGS, syntax, 2, -1 );
         return 1;
      }

      remote = 1;
   }

   if ( child_pid != -1 )
   {
      fprintf( stderr, "%s: an inferior process is already running.\n", syntax );
      return 1;
   }

   stack_push( stack, args );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, 0 );

      return 1;
   }

   if ( remote )
   {
      stack_push( stack, args->next );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 2, 0 );

         return 1;
      }
   }

   {
      struct object *name, *port = NULL;

      if ( remote )
      {
         port = stack_pop( stack );

         if ( islist( port->flags ) || numberp( port->flags ) == 0 )
         {
            fprintf( stderr, "%s: port number argument is not a fixnum.\n", syntax );
            return 1;
         }
      }

      name = stack_pop( stack );

      if ( islist( name->flags ) || numberp( name->flags ) ||
           type( name->data.atom->flags ) != ATOM_STRING )
      {
         print_err( ERR_ARG_TYPE, syntax, 1, ERR_STRING );
         return 1;
      }

      if ( remote )
         child_fd = open_remote( name->data.atom->data.string->string, number( port->data.atom ));
      else
         child_fd = child_open( syntax, name->data.atom->data.string->string );
   }

   child_eof = 0;
   return 0;
}

int do_child_running( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   stack_push( stack, make_atom_from_number( ( child_pid == -1 ? 0 : 1 )));

   return 0;
}

int do_child_write( char *syntax, struct object *args )
{
   int i;
   struct object *car, *result;

   if ( child_pid == -1 )
   {
      fprintf( stderr, "%s: an inferior process is not running.\n", syntax );
      return 1;
   }
   else if ( child_eof )
   {
      fprintf( stderr, "%s: the writable half of the connection has been closed.\n", syntax );
      return 1;
   }

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   for( i = 1, car = args; car != NULL; car = car->next, ++i )
   {
      stack_push( stack, car );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, i, -1 );
         return 1;
      }

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

      if ( islist( result->flags ) ||
           numberp( result->flags ) ||
           type( result->data.atom->flags ) != ATOM_STRING )
      {
         print_err( ERR_ARG_TYPE, syntax, i, ERR_STRING );
         return 1;
      }
   }

   {
      char *ptr, *current;
      int j, len, written;

      j = i - 1;

      while( --i )
      {
         ptr = (( struct object *)stack->values[ stack->used - i ] )->data.atom->data.string->string;
         len = (( struct object *)stack->values[ stack->used - i ] )->data.atom->data.string->length;

         current = ptr;
         written = 0;

         do
         {
            current += written;
            len -= written;

            if (( written = write( child_fd, current, len )) < 0 )
            {
               fprintf( stderr, "%s: write: %s.\n", syntax, strerror( errno ));
               return 1;
            }
         }
         while( written < len );
      }

      stack_truncate( stack, j );
      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_child_close( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( child_fd != -1 )
   {
      if ( child_eof )
      {
         if ( shutdown( child_fd, SHUT_RD ) < 0 )
         {
            fprintf( stderr, "%s: shutdown(): %s.\n", syntax, strerror( errno ));
            return 1;
         }

         child_eof = 0;
      }
      else
         close( child_fd );

      child_fd = -1;
   }

   if ( child_pid == -2 )
      child_pid = -1;

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int check_child( int block, char *syntax )
{
   int result;
   int fd;
   fd_set in_set;
   struct timeval timeval, *timeptr;

   if ( block )
      timeptr = NULL;
   else
   {
      timeval.tv_sec = 0;
      timeval.tv_usec = 0;
      timeptr = &timeval;
   }

   fd = child_fd;

   FD_ZERO( &in_set );
   FD_SET( fd, &in_set );

   if(( result = select( fd + 1, &in_set, NULL, NULL, timeptr )) < 0 )
      if ( errno != EINTR )
      {
         fprintf( stderr, "%s: select: %s.\n", syntax, strerror( errno ));
         return 1;
      }

   if ( result && FD_ISSET( fd, &in_set ))
      stack_push( stack, make_atom_from_number( 1 ));
   else
      stack_push( stack, make_atom_from_number( 0 ));

   return 0;
}

int do_child_ready( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( child_fd == -1 )
   {
      stack_push( stack, make_atom_from_number( 0 ));
      return 0;
   }

   return check_child( 0, syntax );
}

int do_child_wait( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( child_fd == -1 )
   {
      stack_push( stack, make_atom_from_number( 0 ));
      return 0;
   }

   return check_child( 1, syntax );
}

int do_child_read( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( child_fd == -1 )
   {
      fprintf( stderr, "%s: an inferior process is not running.\n", syntax );
      return 1;
   }

   {
      int result;
      int fd;
      fd_set in_set;
      char buffer[ 1024 ];
      struct timeval timeval;

      timeval.tv_sec = 30;
      timeval.tv_usec = 0;

      fd = child_fd;

      FD_ZERO( &in_set );
      FD_SET( fd, &in_set );

      if (( result = select( fd + 1, &in_set, NULL, NULL, &timeval )) < 0 )
         if ( errno != EINTR )
         {
            fprintf( stderr, "%s: select: %s.\n", syntax, strerror( errno ));
            return 1;
         }

      if ( result && FD_ISSET( fd, &in_set ))
      {
         if (( result = read( fd, buffer, sizeof( buffer ) - 1 )) < 0 )
         {
            fprintf( stderr, "%s: read: %s.\n", syntax, strerror( errno ));
            return 1;
         }

         if ( result == 0 )
         {
            do_child_close( syntax, NULL );
            stack_pop( stack );
            stack_push( stack, make_atom_from_number( 0 ));
         }
         else
         {
            buffer[ result ] = '\0';
            stack_push( stack, make_atom_from_string( buffer, result ));
         }
      }
      else
         stack_push( stack, make_atom_from_string( "", 0 ));
   }

   return 0;
}

int do_protect( char *syntax, struct object *args )
{
   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   {
      struct object *temp, *temp_thrown;
      int temp_stop;

      stack_push( stack, args );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 1, -1 );

         temp_thrown = thrown;
         temp_stop = stop;
         temp = NULL;
      }
      else
      {
         temp_thrown = NULL;
         temp_stop = 0;
         temp = stack_pop( stack );
      }

      if ( args->next != NULL && do_progn( syntax, args->next ))
         return 1;

      stop = temp_stop;
      thrown = temp_thrown;

      if ( temp == NULL )
         return 1;

      stack_pop( stack );
      stack_push( stack, temp );
   }

   return 0;
}

int do_tailcall( char *syntax, struct object *args )
{
   struct stack *temp;
   struct object *car;
   struct closure *closure;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   if ( current_closure == NULL )
   {
      fprintf( stderr, "%s: no closure is being applied.\n", syntax );
      return 1;
   }

   stack_push( stack, args );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 0, 1 );
      return 1;
   }

   car = stack_pop( stack );

   if ( numberp( car->flags ) )
   {
      if ( car->data.atom != NULL )
      {
         print_err( ERR_ARG_TYPE, syntax, 1, ERR_CLOSURE );
         return 1;
      }

      closure = current_closure;
   }
   else if ( type( car->data.atom->flags ) != ATOM_CLOSURE )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_CLOSURE );
      return 1;
   }
   else
      closure = car->data.atom->data.closure;

   temp = make_stack();

   if ( make_act_record( args->next, closure, temp, syntax, 1 ))
   {
      stack_free( temp );
      return 1;
   }

   local_env = make_atom_from_act_record( temp );
   current_closure = closure;

   stop = 1;
   tailcall = 1;
   tailcall_syntax = syntax;

   return 1;
}

int do_stat( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct stat st;
      struct group *gp;
      struct passwd *pw;
      struct object *obj, *result;

      obj = stack_pop( stack );

      if ( stat( obj->data.atom->data.string->string, &st ) < 0 )
      {
         if ( errno == ENOENT || errno == EACCES || errno == ENOTDIR )
         {
            stack_push( stack, make_object());
            setlist( ( *( struct object **)stack->top )->flags );
            return 0;
         }

         fprintf( stderr, "%s: stat: %s.\n", syntax, strerror( errno ));
         return 1;
      }

      result = make_object();
      setlist( result->flags );
      stack_push( stack, result );

      pw = getpwuid( st.st_uid );

      if ( pw == NULL )
         obj = make_atom_from_number( st.st_uid );
      else
         obj = make_atom_from_string( pw->pw_name, strlen( pw->pw_name ));

      result->data.head = obj;

      gp = getgrgid( st.st_gid );

      if ( gp == NULL )
         obj->next = make_atom_from_number( st.st_gid );
      else
         obj->next = make_atom_from_string( gp->gr_name, strlen( gp->gr_name ));

      obj->next->next = make_atom_from_number( st.st_atime );
      obj->next->next->next= make_atom_from_number( st.st_mtime );

      obj->next->next->next->next = make_atom_from_number( st.st_size );
   }

   return 0;
}

int do_mkdir( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *obj;
      int mode;

      mode = S_IRWXU | S_IRGRP | S_IXGRP | S_IROTH | S_IXOTH;

      obj = ( struct object *)stack_pop( stack );
      mode = mkdir( obj->data.atom->data.string->string, mode );

      if ( mode < 0 )
      {
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 0;
      }

      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_realpath( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *obj;
      char real[ MAXPATHLEN + 1 ], *ptr = NULL;

      obj = stack_pop( stack );

      if ( *obj->data.atom->data.string->string == '\0' )
      {
         stack_push( stack, obj );
         return 0;
      }

      ptr = expand_tilde( obj->data.atom->data.string->string );

      if ( realpath( ptr, real ) == NULL )
         stack_push( stack, make_atom_from_string( "", 0 ));
      else
         stack_push( stack, make_atom_from_string( real, strlen( real )));

      free( ptr );
   }

   return 0;
}

int do_access( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      int mode;
      struct object *obj1, *obj2;

      obj2 = stack_pop( stack );
      obj1 = stack_pop( stack );
      mode = number( obj2->data.atom );

      if ( mode != 0 && mode != 1 && mode != 2 )
      {
         fprintf( stderr, "%s: unrecognized mode: %d.\n",
                  syntax, mode );
         return 1;
      }

      mode = ( mode ? ( mode == 1 ? W_OK : X_OK ) : R_OK );
      mode = access( obj1->data.atom->data.string->string, mode );

      stack_push( stack, make_atom_from_number( ( mode ? 0 : 1 )));
   }

   return 0;
}

void adjust_bookmarks( int start, int quantity )
{
   int i, line;
   struct stack *keys;

   if ( buffer == NULL )
      return;

   keys = get_hash_keys( bookmarks );

   for( i = 0; i < keys->used; ++i )
   {
      line = ( int )lookup_elt( bookmarks, ( int )keys->values[ i ] );

      if ( line > 0 && line > start )
         insert_elt( bookmarks,
                     ( int )keys->values[ i ],
                     ( struct object *)( line + quantity ) );
   }

   stack_free( keys );
}

void delete_bookmarks( int start, int end )
{
   int i, line;
   struct stack *keys;

   if ( buffer == NULL )
      return;

   keys = get_hash_keys( bookmarks );

   for( i = 0; i < keys->used; ++i )
   {
      line = ( int )lookup_elt( bookmarks, ( int )keys->values[ i ] );

      if ( line > 0 && line >= start && line <= end )
         insert_elt( bookmarks,
                    ( int )keys->values[ i ],
                    ( struct object *)-1 );
   }

   stack_free( keys );
}

int do_setmark( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_ATOM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   {
      struct object *car1, *car2;
      int line, last;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      line = number( car2->data.atom );

      if ( do_lastline( syntax, NULL ))
         return 1;

      last = number( ( *( struct object **)stack->top )->data.atom );
      stack_pop( stack );

      if ( line < 0 || line > last )
      {
         fprintf( stderr, "%s: line %d out of range.\n", syntax,
                  number( car2->data.atom ));
         return 1;
      }

      if ( numberp( car1->flags ) )
         car1 = make_atom_from_number_for_hash_key( number( car1->data.atom ) );

      insert_elt( bookmarks, car1->data.atom->id, ( struct object *)line );
   }

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_getmark( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_ATOM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      return 1;
   }

   {
      struct object *car;
      int line;

      car = stack_pop( stack );
      if ( numberp( car->flags ))
         car = make_atom_from_number_for_hash_key( number( car->data.atom ));

      line = ( int )lookup_elt( bookmarks, car->data.atom->id );
      stack_push( stack, make_atom_from_number( line ));
   }

   return 0;
}

void sigwinch_handler( int signo )
{
   struct winsize winsize;

   if ( ioctl( 1, TIOCGWINSZ, &winsize ) < 0 )
   {
      LINES = COLS = 0;
      return;
   }

   LINES = winsize.ws_row;
   COLS = winsize.ws_col;

#ifdef DEBUG
   fprintf( stderr, "LINES = %d\nCOLS= %d\n", LINES, COLS );
#endif

   sigwinch = 1;
}

int do_boldface( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   putp( bd );
   fflush( stdout );

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_normal( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   putp( me );
   fflush( stdout );

   stack_push( stack, make_atom_from_number( 1 ) );

   return 0;
}

int do_pause( char *syntax, struct object *args )
{
   struct object *car;
   struct timeval timeval;
   int arg1, fd, c, result, was_canon;
   fd_set in_set;

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   arg1 = number( car->data.atom );

   timeval.tv_sec = 0;
   timeval.tv_usec = arg1;

   was_canon = mode;
   nocanon( syntax );

   fd = 0;

   FD_ZERO( &in_set );
   FD_SET( fd, &in_set );

   if(( result = select( fd + 1, &in_set, NULL, NULL, &timeval )) < 0 )
   {
      if ( errno != EINTR )
      {
         fprintf( stderr, "%s: select: %s.\n", syntax, strerror( errno ));
         return 1;
      }

      stack_push( stack, make_atom_from_number( 1 ));
      return 0;
   }

   if ( result == 0 )
   {
      stack_push( stack, make_atom_from_number( 1 ));
      return 0;
   }

   if ( FD_ISSET( fd, &in_set ))
   {
      c = 0;

      if ( read( fd, &c, 1 ) < 0 )
      {
         fprintf( stderr, "%s: read: %s.\n", syntax, strerror( errno ));
         return 1;
      }

      pushed_back = ( int)c;
   }

   if ( was_canon )
      canon( syntax );

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_display( char *syntax, struct object *args )
{
   struct object *car1, *car2, *car3;
   int result, i, last, key, end, start, len, tabstop;
   struct string *s;

   if ( ( int )cl == -1 || ( int )ce == -1 || ( int )cm == -1 )
   {
      fprintf( stderr, "%s: terminal has insufficient capabilities.\n",
               syntax );
      return 1;
   }

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)3 );

   if ( check_args( syntax, args ))
      return 1;

   car3 = stack_pop( stack );
   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   dbt_key.data = &key_data;
   dbt_key.size = sizeof( recno_t );

   if (( result = buffer->seq( buffer, &dbt_key, &dbt_value, R_LAST )) == -1 )
   {
      fprintf( stderr, "%s: db->seq: %s.\n", syntax, strerror( errno ));
      return 1;
   }

   last = *( int *)dbt_key.data;

   key = number( car1->data.atom );

   if ( key < 0 || key > last )
   {
      fprintf( stderr, "%s: line %d out of range.\n", syntax, key );
      return 1;
   }

   start = number( car2->data.atom );

   if ( start < 0 )
   {
      fprintf( stderr, "%s: column %d out of range.\n", syntax, start );
      return 1;
   }

   tabstop = number( car3->data.atom );

   if ( tabstop < 0 )
   {
      fprintf( stderr, "%s: tabstop %d out of range.\n", syntax, tabstop );
      return 1;
   }

   i = 0;
   end = LINES - 1;

   s = make_string();

   if ( key > 0 && last )
      while( key <= last && i < end )
      {
         putp( tgoto( cm, 0, i ));
         putp( ce );

         dbt_key.data = &key_data;
         dbt_key.size = sizeof( recno_t );
         key_data = key;

         if (( result = buffer->get( buffer, &dbt_key, &dbt_value, 0 )) < 0 )
         {
            fprintf( stderr, "%s: db->get: %s.\n", syntax, strerror( errno ));
            string_free( s );
            return 1;
         }
         else if ( result == 1 )
         {
            fprintf( stderr, "%s: db->get: key does not exist.\n", syntax );
            string_free( s );
            return 1;
         }

         {
            int j, limit, offset;
            char *ptr;

            string_truncate( s );

            ptr = ( char *)dbt_value.data;
            len = dbt_value.size;
            offset = 0;

            for( j = 0; j < len; ++j )
            {
               if ( *ptr == '\t' )
               {
                  int spaces;

                  spaces = tabstop - ( j + offset ) % tabstop;
                  offset += spaces - 1;

                  while( spaces-- )
                     string_append( s, ' ' );
               }
               else if ( *ptr != '\r' && *ptr != '\n' )
                  string_append( s, *ptr );

               ++ptr;
            }

            if ( start < s->used )
            {
               limit = MIN( s->used, start + COLS );
               s->str[ limit ] = '\0';
               fputs( &s->str[ start ], stdout );
            }
         }

         ++key;
         ++i;
      }

   while( i < end )
   {
      putp( tgoto( cm, 0, i ));
      putp( ce );
      putchar( '~' );
      ++i;
   }

   fflush( stdout );
   string_free( s );

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_scrollup( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( ( int )sf == -1 || ( int )sc == -1 )
   {
      fprintf( stderr, "%s: terminal has insufficient capabilities.\n",
               syntax );
      return 1;
   }

   putp( sc );
   putp( tgoto( cm, 0, LINES - 1 ));
   putp( sf );
   putp( rc );
   fflush( stdout );

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_scrolldn( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( ( int )sr == -1 || ( int )sc == -1 )
   {
      fprintf( stderr, "%s: terminal has insufficient capabilities.\n",
               syntax );
      return 1;
   }

   putp( sc );
   putp( tgoto( cm, 0, 0 ));
   putp( sr );
   putp( rc );
   fflush( stdout );

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_clearscreen( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( ( int)cl != -1 )
   {
      putp( cl );
      fflush( stdout );
   }

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_goto( char *syntax, struct object *args )
{
   struct object *car1, *car2;
   int y, x;

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   y = number( car1->data.atom );
   x = number( car2->data.atom );

   if ( y < 0 || y > LINES )
   {
      fprintf( stderr, "%s: line index %d out of range.\n",
               syntax, y );
      return 1;
   }

   if ( x < 0 || x > COLS )
   {
      fprintf( stderr, "%s: column index %d out of range.\n",
               syntax, x );
      return 1;
   }

   putp( tgoto( cm, x, y ));
   fflush( stdout );

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_clearline( char *syntax, struct object *args )
{
   struct object *car1, *car2;

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   if ( number( car1->data.atom ) < 0 ||
        number( car1->data.atom ) > LINES - 1 )
   {
      fprintf( stderr, "%s: line %d out of range.\n", syntax,
               number( car1->data.atom ));
      return 1;
   }

   if ( number( car2->data.atom ) < 0 ||
        number( car2->data.atom ) > COLS - 1 )
   {
      fprintf( stderr, "%s: column %d out of range.\n", syntax,
               number( car2->data.atom ));
      return 1;
   }

   putp( tgoto( cm, number( car2->data.atom ),
                    number( car1->data.atom )));
   putp( ce );
   fflush( stdout );

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_hide( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   putp( vi );
   fflush( stdout );

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_show( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   putp( ve );
   fflush( stdout );

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_insertln( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( ( int )al == - 1 )
   {
      fprintf( stderr, "%s: terminal has insufficient capabilities.\n",
               syntax );
      return 1;
   }

   putp( al );
   fflush( stdout );

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_getchar( char *syntax, struct object *args )
{
   int result, c, was_canon;

   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( pushed_back >= 0 )
   {
      stack_push( stack, make_atom_from_number( pushed_back ));
      pushed_back = -1;
      return 0;
   }

   if (( was_canon = mode ))
      nocanon( syntax );

   fflush( stdout );
   blocking_fd( 0 );

AGAIN:
   c = 0;
   result = read( 0, &c, 1 );

   if ( result == 0 )
      stack_push( stack, make_atom_from_number( -1 ));
   else if ( result < 0 )
   {
      switch( errno )
      {
         case EINTR:
            if ( !sigwinch )
               goto AGAIN;
            else
            {
               stack_push( stack, make_atom_from_number( -2 ));
               sigwinch = 0;
            }
            break;

         case EAGAIN:
            goto AGAIN;

         default:
            stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      }
   }
   else
      stack_push( stack, make_atom_from_number( c ));

   if ( was_canon )
      canon( syntax );

   return 0;
}

int do_pushback( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   car = stack_pop( stack );
   pushed_back = number( car->data.atom );

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_canon( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *) 0 );

   if ( check_args( syntax, args ))
      return 1;

   canon( syntax );
   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_nocanon( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   nocanon( syntax );
   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_noprinter( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   printer = 0;

   return 0;
}

int do_printer( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   printer = 1;
   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_shexec( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      char *exec_args[ 4 ];

      car = stack_pop( stack );

      exec_args[ 0 ] = "/bin/sh";
      exec_args[ 1 ] = "-c";
      exec_args[ 2 ] = car->data.atom->data.string->string;
      exec_args[ 3 ] = NULL;

      fflush( stdout );
      fflush( stderr );

      execv( exec_args[ 0 ], exec_args );

      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
   }

   return 0;
}

int do_exec( char *syntax, struct object *args )
{
   struct object *ptr;
   char **exec_args;
   int n;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, -1 );
      return 1;
   }

   for( ptr = args, n = 1; ptr != NULL; ptr = ptr->next, ++n )
   {
      stack_push( stack, ptr );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, n, -1 );

         return 1;
      }

      if ( islist( ( *( struct object **)stack->top )->flags ) ||
           numberp( ( *( struct object **)stack->top )->flags ) ||
           type( ( *( struct object **)stack->top )->data.atom->flags ) != ATOM_STRING )
      {
         print_err( ERR_ARG_TYPE, syntax, n, ERR_STRING );
         return 1;
      }
   }

   exec_args = memory( n * sizeof( char * ) );
   exec_args[ --n ] = NULL;

   for( --n; n >= 0; --n )
   {
      ptr = stack_pop( stack );
      exec_args[ n ] = ptr->data.atom->data.string->string;
   }

   fflush( stdout );
   fflush( stderr );

   execv( exec_args[ 0 ], exec_args );
   free( exec_args );

   stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));

   return 0;
}

int do_truncate( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1;

      car1 = stack_pop( stack );

      if ( ftruncate( 1, number( car1->data.atom )) < 0 )
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      else
         stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_symbolp( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;

      car = stack_pop( stack );

      if ( islist( car->flags ) == 0 &&
           numberp( car->flags ) == 0 &&
           type( car->data.atom->flags ) == ATOM_SYMBOL )
         stack_push( stack, make_atom_from_number( 1 ));
      else
         stack_push( stack, make_atom_from_number( 0 ));
   }

   return 0;
}

int do_regexpp( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;

      car = stack_pop( stack );

      if ( islist( car->flags ) == 0 &&
           numberp( car->flags ) == 0 &&
           type( car->data.atom->flags ) == ATOM_REGEXP )
         stack_push( stack, make_atom_from_number( 1 ));
      else
         stack_push( stack, make_atom_from_number( 0 ));
   }

   return 0;
}

int do_tablep( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;

      car = stack_pop( stack );

      if ( islist( car->flags ) == 0 &&
           numberp( car->flags ) == 0 &&
           type( car->data.atom->flags ) == ATOM_TABLE )
         stack_push( stack, make_atom_from_number( 1 ));
      else
         stack_push( stack, make_atom_from_number( 0 ));
   }

   return 0;
}

int do_stackp( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;

      car = stack_pop( stack );

      if ( islist( car->flags ) == 0 &&
           numberp( car->flags ) == 0 &&
           type( car->data.atom->flags ) == ATOM_STACK )
         stack_push( stack, make_atom_from_number( 1 ));
      else
         stack_push( stack, make_atom_from_number( 0 ));
   }

   return 0;
}

int do_intrinsicp( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;

      car = stack_pop( stack );

      if ( islist( car->flags ) == 0 &&
           numberp( car->flags ) == 0 &&
           type( car->data.atom->flags ) == ATOM_INTRINSIC )
         stack_push( stack, make_atom_from_number( 1 ));
      else
         stack_push( stack, make_atom_from_number( 0 ));
   }

   return 0;
}

int do_closurep( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;

      car = stack_pop( stack );

      if ( islist( car->flags ) == 0 &&
           numberp( car->flags ) == 0 &&
           type( car->data.atom->flags ) == ATOM_CLOSURE )
         stack_push( stack, make_atom_from_number( 1 ));
      else
         stack_push( stack, make_atom_from_number( 0 ));
   }

   return 0;
}

int do_macrop( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;

      car = stack_pop( stack );

      if ( islist( car->flags ) == 0 &&
           numberp( car->flags ) == 0 &&
           type( car->data.atom->flags ) == ATOM_MACRO )
         stack_push( stack, make_atom_from_number( 1 ));
      else
         stack_push( stack, make_atom_from_number( 0 ));
   }

   return 0;
}

int do_dynamic_let( char *syntax, struct object *args )
{
   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, 0 );
      return 1;
   }

   if ( islist( args->flags ) == 0 )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_LIST );
      return 1;
   }

   if ( args->data.head == NULL )
   {
      fprintf( stderr, "%s: argument 1 is the empty list.\n",
               syntax );
      return 1;
   }

   if ( args->next == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 2, 0 );
      return 1;
   }

   if ( args->data.head == NULL )
   {
      fprintf( stderr, "%s: argument 1 is the empty list.\n", syntax );
      return 1;
   }

   if ( args->data.head->next == NULL )
   {
      fprintf( stderr, "%s: element 1 of argument 1 contains only one sub-element.\n", syntax );
      return 1;
   }

   if ( args->data.head->next->next != NULL )
   {
      fprintf( stderr, "%s: element 1 of argument 1 contains more than two sub-elements.\n", syntax );
      return 1;
   }

   if ( islist( args->data.head->flags ) == 1 ||
        numberp( args->data.head->flags ) ||
        type( args->data.head->data.atom->flags ) != ATOM_SYMBOL )
   {
      fprintf( stderr, "%s: element 1 of argument 1 is not a symbol.\n", syntax );
      return 1;
   }

   {
      struct object *value, *old;
      int result;

      stack_push( stack, args->data.head->next );

      if ( evaluate() )
      {
         if ( !stop )
            fprintf( stderr, "%s: evaluation of expression to bind failed.\n", syntax );

         return 1;
      }

      value = stack_pop( stack );
      old = lookup_binding( args->data.head->data.atom->id );
      insert_binding( args->data.head->data.atom->id, value );

      if ( old != NULL )
         stack_push( stack, old );

      result = do_progn( syntax, args->next );

      if ( old != NULL )
         insert_binding( args->data.head->data.atom->id, old );
      else
         remove_binding( args->data.head->data.atom->id );

      if ( result == 0 && old != NULL )
      {
         struct object *returned;

         returned = stack_pop( stack );
         stack_pop( stack );
         stack_push( stack, returned );
      }

      return result;
   }
}

int do_chmod( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2;
      struct stat st;
      mode_t newmode;
      void *mode;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      mode = setmode( car1->data.atom->data.string->string );

      if ( mode == NULL )
      {
         char buffer[ 256 ];

         snprintf( buffer, sizeof( buffer ), "Invalid mode: %s",
                   car1->data.atom->data.string->string );
         stack_push( stack, make_atom_from_string( buffer, strlen( buffer )));
         return 0;
      }

      if ( stat( car2->data.atom->data.string->string, &st ) < 0 )
      {
         free( mode );
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 0;
      }

      newmode = getmode( mode, st.st_mode );
      free( mode );

      if ( chmod( car2->data.atom->data.string->string, newmode ) < 0 )
      {
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 1;
      }

      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_chown( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)3 );

   if ( check_args( syntax, args ))
      return 1;

   {
      char buffer[ 256 ];
      struct object *car1, *car2, *car3;
      int gid, uid;

      car3 = stack_pop( stack );
      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      gid = uid = -1;

      if ( car1->data.atom->data.string->length )
      {
         struct passwd *pass;

         if ( getuid() != 0 && geteuid() != 0 )
         {
            stack_push( stack, make_atom_from_string( "only root may change user", 25 ));
            return 0;
         }

         pass = getpwnam( car1->data.atom->data.string->string );

         if ( pass == NULL )
         {
            snprintf( buffer, sizeof( buffer ), "no such user: %s",
                      car1->data.atom->data.string->string );
            stack_push( stack, make_atom_from_string( buffer, strlen( buffer )));
            return 0;
         }

         uid = pass->pw_uid;
      }

      if ( car2->data.atom->data.string->length == 0 || uid == -1 )
      {
         struct stat st;

         if ( stat( car3->data.atom->data.string->string, &st ) < 0 )
         {
            stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
            return 0;
         }

         if ( uid == -1 )
            uid = st.st_uid;
         else
            gid = st.st_gid;
      }

      if ( car2->data.atom->data.string->length )
      {
         struct group *group;

         if (( group = getgrnam( car2->data.atom->data.string->string )) == NULL )
         {
            snprintf( buffer, sizeof( buffer ), "no such group: %s",
                      car2->data.atom->data.string->string );
            stack_push( stack, make_atom_from_string( buffer, strlen( buffer )));
            return 0;
         }

         gid = group->gr_gid;
      }

      if ( chown( car3->data.atom->data.string->string, uid, gid ) < 0 )
      {
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 0;
      }

      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_clear( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STACK );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2;
      int n;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      n = number( car2->data.atom );

      if ( n < 0 )
      {
         fprintf( stderr, "%s: argument 2 is negative number.\n", syntax );
         return 1;
      }

      while( n-- && car1->data.atom->data.stack->used )
         stack_pop( car1->data.atom->data.stack );

      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_basename( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void*)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      char *ptr;

      car = stack_pop( stack );

      if (( ptr = basename( car->data.atom->data.string->string )) == NULL )
         stack_push( stack, make_atom_from_string( "", 0 ));
      else
         stack_push( stack, make_atom_from_string( ptr, strlen( ptr )));
   }

   return 0;
}

int do_dirname( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void*)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      char *ptr;

      car = stack_pop( stack );

      if (( ptr = dirname( car->data.atom->data.string->string )) == NULL )
         stack_push( stack, make_atom_from_string( "", 0 ));
      else
         stack_push( stack, make_atom_from_string( ptr, strlen( ptr )));
   }

   return 0;
}

int do_checkpass( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2;
      struct passwd *passwd;
      char *encrypted;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      if (( passwd = getpwnam( car1->data.atom->data.string->string )) == NULL )
      {
         stack_push( stack, make_atom_from_number( 0 ));
         return 0;
      }

      if (( encrypted = crypt( car2->data.atom->data.string->string,
                               passwd->pw_passwd )) == NULL )
      {
         stack_push( stack, make_atom_from_number( 0 ));
         return 0;
      }

      if ( strcmp( passwd->pw_passwd, encrypted ))
      {
         stack_push( stack, make_atom_from_number( 0 ));
         return 0;
      }

      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_setuid( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      struct passwd *passwd;

      car = stack_pop( stack );

      if (( passwd = getpwnam( car->data.atom->data.string->string )) == NULL )
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      else if ( setuid( passwd->pw_uid ) < 0 )
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      else
         stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_getuid( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *result;
      struct passwd *passwd;

      result = make_object();
      setlist( result->flags );
      stack_push( stack, result );

      if (( passwd = getpwuid( getuid() )) == NULL )
         return 0;

      result->data.head = make_atom_from_string( passwd->pw_name, strlen( passwd->pw_name ));
      result->data.head->next = make_atom_from_number( passwd->pw_uid );
   }

   return 0;
}

int do_getgid( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *result;
      struct group *gp;

      result = make_object();
      setlist( result->flags );
      stack_push( stack, result );

      if (( gp = getgrgid( getgid() )) == NULL )
         return 0;

      result->data.head = make_atom_from_string( gp->gr_name, strlen( gp->gr_name ));
      result->data.head->next = make_atom_from_number( gp->gr_gid );
   }

   return 0;
}

int do_geteuid( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *result;
      struct passwd *passwd;

      result = make_object();
      setlist( result->flags );
      stack_push( stack, result );

      if (( passwd = getpwuid( geteuid() )) == NULL )
         return 0;

      result->data.head = make_atom_from_string( passwd->pw_name, strlen( passwd->pw_name ));
      result->data.head->next = make_atom_from_number( passwd->pw_uid );
   }

   return 0;
}

int do_seteuid( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      struct passwd *passwd;

      car = stack_pop( stack );

      if (( passwd = getpwnam( car->data.atom->data.string->string )) == NULL )
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      else if ( seteuid( passwd->pw_uid ) < 0 )
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      else
         stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_seek( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)3 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2, *car3;
      char *w;
      int fd, offset, whence;

      car3 = stack_pop( stack );
      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      if (( fd = number( car1->data.atom )) != 0 && fd != 2 && fd != 1 )
      {
         fprintf( stderr, "%s: descriptor argument out of range: %d.\n", syntax, fd );
         return 1;
      }

      offset = number( car2->data.atom );
      w = car3->data.atom->data.string->string;

      if ( strcmp( w, "SEEK_SET") == 0 )
         whence = SEEK_SET;
      else if ( strcmp( w, "SEEK_CUR" ) == 0 )
         whence = SEEK_CUR;
      else if ( strcmp( w, "SEEK_END" ) == 0 )
         whence = SEEK_END;
      else
      {
         fprintf( stderr, "%s: unrecognized whence argument: %s.\n", syntax, w );
         return 1;
      }

      if  ( fd == 0 )
      {
         if (( offset = lseek( fd, offset, whence )) < 0 )
         {
            stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
            return 0;
         }
      }
      else
      {
         if (( offset = fseek( ( fd == 1 ? stdout : stderr ), offset, whence ))
             < 0 )
         {
            stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
            return 0;
         }
      }

      stack_push( stack, make_atom_from_number( offset ));
   }

   return 0;
}

struct object *make_atom_directly_from_string( char *s, int len )
{
   struct atom *entry;
   struct object *object;

   entry = get_id( s, len, 0 );

   if ( entry->flags == 0 )
   {
      entry->flags = ATOM_STRING;
      entry->data.string = memory( sizeof( struct lstring ));
      entry->data.string->length = len - 1;
      entry->data.string->string = &entry->syntax[ 1 ];
   }
   else
      free( s );

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

   return object;
}

int do_getchars( char *syntax, struct object *args )
{
   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 1, 0 );
      return 1;
   }
   else if ( args->next == NULL )
   {
      stack_push( arg_stack, ( void *)ERR_FIXNUM );
      stack_push( arg_stack, ( void *)1 );

      if ( check_args( syntax, args ))
         return 1;
   }
   else if ( args->next->next != NULL )
   {
      print_err( ERR_MORE_ARGS, syntax, 2, 0 );
      return 1;
   }
   else
   {
      stack_push( arg_stack, ( void *)ERR_FIXNUM );
      stack_push( arg_stack, ( void *)ERR_FIXNUM );
      stack_push( arg_stack, ( void *)2 );

      if ( check_args( syntax, args ))
         return 1;
   }

   {
      struct object *car;
      char *buffer, *ptr;
      int total, timeout, returned;
      struct itimerval value;

      timeout = 0;

      if ( args->next != NULL )
      {
         car = stack_pop( stack );
         timeout = number( car->data.atom );
      }

      car = stack_pop( stack );
      total = number( car->data.atom );

      if ( total == 0 )
      {
         stack_push( stack, make_atom_from_string( "", 0 ));
         return 0;
      }

      if ( total < 0 )
      {
         fprintf( stderr, "%s: argument 1 < 0.\n", syntax );
         return 1;
      }

      buffer = memory( total + 2 );
      buffer[ 0 ] = '"';
      ptr = &buffer[ 1 ];

AGAIN:
      if ( timeout )
      {
         value.it_interval.tv_sec = 0;
         value.it_interval.tv_usec = 0;
         value.it_value.tv_sec = timeout;
         value.it_value.tv_usec = 0;

         setitimer( ITIMER_REAL, &value, NULL );
      }

      returned = read( 0, ptr, total );

      if ( timeout )
      {
         value.it_value.tv_sec = 0;
         value.it_value.tv_usec = 0;
         setitimer( ITIMER_REAL, &value, NULL );
      }

      if ( returned < 0 )
      {
         if ( sigalrm )
         {
            if ( ptr != &buffer[ 1 ] )
            {
               *ptr = '\0';
               stack_push( stack, make_atom_directly_from_string( buffer, ptr - buffer ));
            }
            else
            {
               stack_push( stack, make_atom_from_string( "", -1 ));
               free( buffer );
            }

            sigalrm = 0;
            return 0;
         }
         else if ( errno == EINTR || errno == EAGAIN )
            goto AGAIN;

         free( buffer );
         fprintf( stderr, "%s: read: %s.\n", syntax, strerror( errno ));
         return 1;
      }

      if ( returned == 0 )
      {
         if ( ptr != &buffer[ 1 ] )
         {
            *ptr = '\0';
            stack_push( stack, make_atom_directly_from_string( buffer,  ptr - buffer ));
         }
         else
         {
            stack_push( stack, make_atom_from_number( 0 ));
            free( buffer );
         }

         return 0;
      }

      if ( returned < total )
      {
         ptr = &ptr[ returned ];
         total -= returned;
         goto AGAIN;
      }

      returned += ptr - buffer;
      buffer[ returned ] = '\0';

      stack_push( stack, make_atom_directly_from_string( buffer, returned ));
   }

   return 0;
}

int do_readlock( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   {
      int result;

      if (( result = flock( 0, LOCK_SH | LOCK_NB )) < 0 )
      {
         if ( errno == EWOULDBLOCK )
            stack_push( stack, make_atom_from_number( 0 ));
         else
            stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 0;
      }

      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_writelock( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   {
      int result;

      if (( result = flock( 1, LOCK_EX | LOCK_NB )) < 0 )
      {
         if ( errno == EWOULDBLOCK )
            stack_push( stack, make_atom_from_number( 0 ));
         else
            stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 0;
      }

      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_unlock( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      int result, fd;

      car = stack_pop( stack );
      fd = number( car->data.atom );

      if ( fd != 0 && fd != 1 )
      {
         fprintf( stderr, "%s: invalid descriptor: %d.\n", syntax, fd );
         return 1;
      }

      if (( result = flock( fd, LOCK_UN | LOCK_NB )) < 0 )
      {
         if ( errno == EWOULDBLOCK )
            stack_push( stack, make_atom_from_number( 0 ));
         else
            stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 0;
      }

      stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_hostname( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   {
      char hostname[ MAXHOSTNAMELEN + 1 ];

      if ( gethostname( hostname, MAXHOSTNAMELEN ) < 0 )
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      else
         stack_push( stack, make_atom_from_string( hostname, strlen( hostname )));
   }

   return 0;
}

int do_symlink( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      if ( symlink( car1->data.atom->data.string->string,
                    car2->data.atom->data.string->string ) < 0 )
      {
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 0;
      }
   }

   stack_push( stack, make_atom_from_number( 1 ));
   return 0;
}

int do_gecos( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct passwd *passwd;
      struct object *car;

      car = stack_pop( stack );

      if (( passwd = getpwnam( car->data.atom->data.string->string )) == NULL )
      {
         stack_push( stack, make_atom_from_string( "", 0 ));
         return 0;
      }

      stack_push( stack, make_atom_from_string( passwd->pw_gecos, strlen( passwd->pw_gecos )));
   }

   return 0;
}

struct object *make_empty_list()
{
   struct object *obj;

   obj = make_object();
   setlist( obj->flags );

   return obj;
}

int do_record( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car, **result, **ptr;
      int size, i;

      car = stack_pop( stack );
      size = number( car->data.atom );

      if ( size < 1 )
      {
         fprintf( stderr, "%s: argument 1 is less than 1.\n", syntax );
         return 1;
      }

      result = memory( ( size * sizeof( struct object * )) + 1 );

      ptr = result;
      *ptr++ = ( struct object *)size;

      for( i = 0; i < size; ++i )
         *ptr++ = make_empty_list();

      stack_push( stack, make_atom_from_record( result ));
   }

   return 0;
}

int do_getfield( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_RECORD );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2;
      int idx;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      idx = number( car2->data.atom );

      if ( idx < 0 )
      {
         fprintf( stderr, "%s: index %d is less than 0.\n", syntax, idx );
         return 1;
      }
      else if ( idx >= *( int *)car1->data.atom->data.record )
      {
         fprintf( stderr, "%s: index %d beyond end of record.\n", syntax, idx );
         return 1;
      }

      stack_push( stack, ( ( struct object **)car1->data.atom->data.record )[ idx + 1 ] );
   }

   return 0;
}

int do_setfield( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_RECORD );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)3 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2, *car3;
      int idx;

      car3 = stack_pop( stack );
      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      idx = number( car2->data.atom );

      if ( idx < 0 )
      {
         fprintf( stderr, "%s: index %d is less than 0.\n", syntax, idx );
         return 1;
      }
      else if ( idx >= *( int *)car1->data.atom->data.record )
      {
         fprintf( stderr, "%s: index %d beyond end of record.\n", syntax, idx );
         return 1;
      }

      (( struct object **)car1->data.atom->data.record )[ idx + 1 ] = car3;

      stack_push( stack, car3 );
   }

   return 0;
}

int do_extend( char *syntax, struct object *args )
{
   if ( local_env == NULL )
   {
      fprintf( stderr, "%s: no local environment is active.\n", syntax );
      return 1;
   }

   stack_push( arg_stack, ( void *)ERR_SYMBOL );
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      stack_push( local_env->data.atom->data.act_record, car2 );
      stack_push( local_env->data.atom->data.act_record, ( void *)car1->data.atom->id );

      stack_push( stack, car2 );
   }

   return 0;
}

int do_gc( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   gc = 1;
   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_recordp( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)-1 );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;

      car = stack_pop( stack );

      if ( islist( car->flags ) == 00 &&
           numberp( car->flags ) == 0 &&
           type( car->data.atom->flags ) == ATOM_RECORD )
         stack_push( stack, make_atom_from_number( 1 ));
      else
         stack_push( stack, make_atom_from_number( 0 ));
   }

   return 0;
}

int cfor( struct object *args )
{
   int i, j;
   struct object *loop, *body, *test, *final, *ptr, *result, *after;

   loop = args->data.head;
   body = args->next;

   if ( loop->next == NULL ||
        islist( loop->next->flags ) == 0 ||
        loop->next->next == NULL ||
        islist( loop->next->next->flags ) == 0 )
   {
      fprintf( stderr, "for: if the first element of the first argument list is itself a list,\n"
                       "     then all of the first argument list's elements must also be lists.\n" );
      return 1;
   }

   if ( loop->next->next->next != NULL )
   {
      fprintf( stderr, "for: first argument list has more than 3 elements.\n" );
      return 1;
   }

   if ( loop->next->data.head == NULL )
   {
      fprintf( stderr, "for: test/return list, is the empty list.\n" );
      return 1;
   }

   test = loop->next->data.head;
   final = test->next;
   after = loop->next->next->data.head;

   if ( loop->data.head != NULL )
   {
      for( i = 1, ptr = loop->data.head; ptr != NULL; ptr = ptr->next, ++i )
      {
         stack_push( stack, ptr );

         if ( evaluate() )
         {
            if ( !stop )
               fprintf( stderr, "for: evaluation of initialization expression %d failed.\n", i );

            return 1;
         }

         stack_pop( stack );
      }
   }

   for( ; ; )
   {
      stack_push( stack, test );

      if ( evaluate() )
      {
         if ( !stop )
            fprintf( stderr, "for: evaluation of test expression failed.\n" );

         return 1;
      }

      result = stack_pop( stack );
      j = stack->used;

      if (( islist( result->flags ) == 1 && result->data.head == NULL ) ||
            result->data.atom == NULL ||
            result->data.atom == empty->data.atom )
      {
         for( i = 1, ptr = final; ptr != NULL; ptr = ptr->next, ++i )
         {
            stack_push( stack, ptr );

            if ( evaluate() )
            {
               if ( !stop )
                  fprintf( stderr, "for: evaluation of return expression %d failed.\n", i );

               return 1;
            }

            result = stack_pop( stack );
         }

         stack_push( stack, result );
         break;
      }

      for( i = 1, ptr = body; ptr != NULL; ptr = ptr->next, ++i )
      {
         stack_push( stack, ptr );

         if ( evaluate() )
         {
            if ( !stop )
               fprintf( stderr, "for: evaluation of body form %d failed.\n", i );

            if ( next_iteration )
            {
               next_iteration = 0;
               stop = 0;
               thrown = NULL;
               stack_truncate( stack, stack->used - j );
               goto CONTINUE;
            }

            return 1;
         }

         stack_pop( stack );
      }

   CONTINUE:
      if ( after != NULL )
         for( i = 1, ptr = after; ptr != NULL; ptr = ptr->next, ++i )
         {
            stack_push( stack, ptr );

            if ( evaluate() )
            {
               if ( !stop )
                  fprintf( stderr, "for: evaluation of after expression %d failed.\n", i );

               return 1;
            }

            stack_pop( stack );
         }
   }

   return 0;
}

int do_for( char *syntax, struct object *args )
{
   struct object *symbol, *from, *to, *incr;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 1, 0 );
      return 1;
   }

   if ( islist( args->flags ) == 0 )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_LIST );
      return 1;
   }

   if ( args->data.head == NULL )
   {
      fprintf( stderr, "%s: argument 1 is empty list.\n", syntax );
      return 1;
   }

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

   /*
    * if the first element is a list, try to execute a c-like for loop.
    */

   if ( islist( args->data.head->flags ) )
      return cfor( args );

   if ( numberp( args->data.head->flags ) ||
        type( args->data.head->data.atom->flags ) != ATOM_SYMBOL )
   {
      fprintf( stderr, "%s: element 1 of argument 1 must be a symbol.\n", syntax );
      return 1;
   }

   symbol = args->data.head;
   from = args->data.head->next;

   if ( from == NULL )
   {
      fprintf( stderr, "%s: range elements missing from argument 1.\n", syntax );
      return 1;
   }

   to = from->next;

   if ( to == NULL )
   {
      fprintf( stderr, "%s: end value of range missing from argument 1.\n", syntax );
      return 1;
   }

   incr = to->next;

   if ( incr != NULL && incr->next != NULL )
   {
      fprintf( stderr, "%s: too many elements in argument 1.\n", syntax );
      return 1;
   }

   stack_push( stack, from );

   if ( evaluate() )
   {
      if ( !stop )
         fprintf( stderr, "%s: error evaluating \"from\" value in argument 1.\n", syntax );

      return 1;
   }

   stack_push( stack, to );

   if ( evaluate() )
   {
      if ( !stop )
         fprintf( stderr, "%s: error evaluating \"to\" value in argument 1.\n", syntax );

      return 1;
   }

   if ( incr != NULL )
   {
      stack_push( stack, incr );

      if ( evaluate() )
      {
         if ( !stop )
            fprintf( stderr, "%s: error evaluation \"increment\" value in argument 1.\n", syntax );

         return 1;
      }

      incr = stack_pop( stack );
   }

   to = stack_pop( stack );
   from = stack_pop( stack );

   if ( islist( from->flags ) || numberp( from->flags ) == 0 )
   {
      fprintf( stderr, "%s: \"from\" value not a number.\n", syntax );
      return 1;
   }

   if ( islist( to->flags ) || numberp( to->flags ) == 0 )
   {
      fprintf( stderr, "%s: \"to\" value not a number.\n", syntax );
      return 1;
   }

   if ( incr != NULL && ( islist( incr->flags ) || numberp( incr->flags ) == 0 ))
   {
      fprintf( stderr, "%s: \"increment\" value not a number.\n", syntax );
      return 1;
   }

   {
      int start, end, inc, idx, no_env, i, old;
      struct object *ptr, *result = NULL, **act_ptr;

      start = number( from->data.atom );
      end = number( to->data.atom );

      inc = ( start <= end ? 1 : -1 );

      if ( incr != NULL )
         inc *= abs( number( incr->data.atom ) );

      no_env = ( local_env == NULL ? 1 : 0 );

      if ( no_env )
      {
         local_env = make_atom_from_act_record( make_stack() );
         stack_push( local_env->data.atom->data.act_record, NULL );
         old = -1;
      }
      else
         old = local_env->data.atom->data.act_record->used;

      stack_push( local_env->data.atom->data.act_record, make_atom_from_number( start ));
      act_ptr = ( struct object **)local_env->data.atom->data.act_record->top;
      stack_push( local_env->data.atom->data.act_record, ( void *)symbol->data.atom->id );

      idx = start;

      while (( inc < 0 ? ( idx >= end ) : ( idx <= end )))
      {
         for( i = 1, ptr = args->next; ptr != NULL; ptr = ptr->next, ++i )
         {
            stack_push( stack, ptr );

            if ( evaluate() )
            {
               if ( next_iteration )
               {
                  next_iteration = 0;
                  stop = 0;
                  thrown = NULL;
                  break;
               }
               else
               {
                  if ( !stop )
                     fprintf( stderr, "%s: error evaluating body expression %d.\n",
                              syntax, i );

                  result = NULL;
                  goto ERROR;
               }
            }

            result = stack_pop( stack );
         }

         if ( numberp( ( *act_ptr )->flags ) == 0 )
         {
            fprintf( stderr, "%s: index variable rebound to non-number.\n", syntax );
            result = NULL;
            goto ERROR;
         }

         ( *act_ptr )->data.atom = ( struct atom *)( idx = number( ( *act_ptr )->data.atom ) + inc );
      }

ERROR:
      if ( no_env )
         local_env = NULL;
      else
      {
         while( local_env->data.atom->data.act_record->used > old )
            stack_pop( local_env->data.atom->data.act_record );
      }

      if ( result == NULL )
         return 1;

      stack_push( stack, result );
   }

   return 0;
}

int do_iterate( char *syntax, struct object *args )
{
   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, 0 );
      return 1;
   }

   stack_push( stack, args );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, 0 );

      return 1;
   }

   {
      struct object *ptr, *result = NULL;
      int i, j;

      result = stack_pop( stack );

      if ( numberp( result->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 1, ERR_FIXNUM );
         return 1;
      }

      for( j = abs( number( result->data.atom ) ); j; --j )
      {
         for( i = 1, ptr = args->next; ptr != NULL; ptr = ptr->next, ++i )
         {
            stack_push( stack, ptr );

            if ( evaluate() )
            {
               if ( next_iteration )
               {
                  next_iteration = 0;
                  stop = 0;
                  thrown = NULL;
                  break;
               }
               else
               {
                  if ( !stop )
                     fprintf( stderr, "%s: error evaluating body expression %d.\n",
                              syntax, i );

                  return 1;
               }
            }

            result = stack_pop( stack );
         }
      }

      stack_push( stack, result );
   }

   return 0;
}

int do_dynamic_extent( char *syntax, struct object *args )
{
   if ( args == NULL )
      stack_push( stack, make_atom_from_number( 1 ));
   else if ( local_env == NULL )
   {
      fprintf( stderr, "%s: no local environment is active.\n", syntax );
      return 1;
   }
   else
   {
      int level, i;
      struct object *ptr, *result = NULL;

      level = local_env->data.atom->data.act_record->used;

      for( i = 1, ptr = args; ptr != NULL; ptr = ptr->next, ++i )
      {
         stack_push( stack, ptr );

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

            result = NULL;
            goto ERROR;
         }

         result = stack_pop( stack );
      }

ERROR:
      stack_truncate( local_env->data.atom->data.act_record,
                      local_env->data.atom->data.act_record->used - level );

      if ( result == NULL )
         return 1;

      stack_push( stack, result );
   }

   return 0;
}

int do_timediff( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2;
      int time1, time2;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      time1 = atoi( car1->data.atom->data.string->string );
      time2 = atoi( car2->data.atom->data.string->string );

      stack_push( stack, make_atom_from_number( time1 - time2 ));
   }

   return 0;
}

int do_timethen( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      int then;
      time_t t;
      struct object *car;
      char buffer[ 32 ];

      car = stack_pop( stack );
      then = number( car->data.atom );

      if ( time( &t ) < 0 )
      {
         fprintf( stderr, "%s: time(): %s\n.", syntax, strerror( errno ));
         return 1;
      }

      snprintf( buffer, sizeof( buffer ), "%ld", ( long int )( t + then ));
      stack_push( stack, make_atom_from_string( buffer, -1 ));
   }

   return 0;
}

int do_inc( char *syntax, struct object *args )
{
   struct object *symbol, *val;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, 0 );
      return 1;
   }

   symbol = args;

   if ( islist( symbol->flags ) ||
        numberp( symbol->flags ) ||
        type( symbol->data.atom->flags ) != ATOM_SYMBOL )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_SYMBOL );
      return 1;
   }

   val = NULL;

   if ( args->next )
   {
      if ( args->next->next )
      {
         print_err( ERR_MORE_ARGS, syntax, 2, 0 );
         return 1;
      }

      stack_push( stack, args->next );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 2, 0 );

         return 1;
      }

      val = stack_pop( stack );

      if ( islist( val->flags ) ||
           numberp( val->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 2, ERR_FIXNUM );
         return 1;
      }
   }

   {
      int local;
      struct object *current;

      local = 1;

      if (( current = lookup_local( symbol->data.atom->id )) == NULL )
      {
         local = 0;
         current = lookup_binding( symbol->data.atom->id );
      }

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

      if ( islist( current->flags ) ||
           numberp( current->flags ) == 0 )
      {
         fprintf( stderr, "%s: symbol %s is not bound to a number.\n", syntax,
                  symbol->data.atom->syntax );
         return 1;
      }

      stack_push( stack,
                  make_atom_from_number(
                     ( val == NULL ? 1 : number( val->data.atom )) +
                     number( current->data.atom ) ));

      if ( local )
         set_local( symbol->data.atom->id, *stack->top );
      else
         insert_binding( symbol->data.atom->id, *stack->top );
   }

   return 0;
}

int do_dec( char *syntax, struct object *args )
{
   struct object *symbol, *val;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, 0 );
      return 1;
   }

   symbol = args;

   if ( islist( symbol->flags ) ||
        numberp( symbol->flags ) ||
        type( symbol->data.atom->flags ) != ATOM_SYMBOL )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_SYMBOL );
      return 1;
   }

   val = NULL;

   if ( args->next )
   {
      if ( args->next->next )
      {
         print_err( ERR_MORE_ARGS, syntax, 2, 0 );
         return 1;
      }

      stack_push( stack, args->next );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 2, 0 );

         return 1;
      }

      val = stack_pop( stack );

      if ( islist( val->flags ) ||
           numberp( val->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 2, ERR_FIXNUM );
         return 1;
      }
   }

   {
      int local;
      struct object *current;

      local = 1;

      if (( current = lookup_local( symbol->data.atom->id )) == NULL )
      {
         local = 0;
         current = lookup_binding( symbol->data.atom->id );
      }

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

      if ( islist( current->flags ) ||
           numberp( current->flags ) == 0 )
      {
         fprintf( stderr, "%s: symbol %s is not bound to a number.\n", syntax,
                  symbol->data.atom->syntax );
         return 1;
      }

      stack_push( stack,
                  make_atom_from_number(
                     number( current->data.atom ) -
                     ( val == NULL ? 1 : number( val->data.atom ))));

      if ( local )
         set_local( symbol->data.atom->id, *stack->top );
      else
         insert_binding( symbol->data.atom->id, *stack->top );
   }

   return 0;
}

int do_setq( char *syntax, struct object *args )
{
   struct object *symbol;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, 0 );
      return 1;
   }

   if ( args->next == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 2, 0 );
      return 1;
   }

   if ( args->next->next )
   {
      print_err( ERR_MORE_ARGS, syntax, 2, 0 );
      return 1;
   }

   symbol = args;

   if ( islist( symbol->flags ) ||
        numberp( symbol->flags ) ||
        type( symbol->data.atom->flags ) != ATOM_SYMBOL )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_SYMBOL );
      return 1;
   }

   stack_push( stack, args->next );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 2, 0 );

      return 1;
   }

   if ( lookup_local( symbol->data.atom->id ) != NULL )
      set_local( symbol->data.atom->id, *stack->top );
   else
      insert_binding( symbol->data.atom->id, *stack->top );

   return 0;
}

int do_gc_freq( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      int freq, old;

      car = stack_pop( stack );
      freq = number( car->data.atom );

      if ( freq < 0 || freq > INT_MAX )
      {
         fprintf( stderr, "%s: argument out of range.\n", syntax );
         return 1;
      }

      old = gc_frequency;
      gc_frequency = freq;

      gc_on = ( freq ? 1 : 0 );

      stack_push( stack, make_atom_from_number( old ));
   }

   return 0;
}

int do_child_eof( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( child_pid == -1 )
   {
      fprintf( stderr, "%s: an inferior process is not running.\n", syntax );
      return 1;
   }
   else if ( child_eof )
   {
      fprintf( stderr, "%s: child_eof has already been invoked on the connection.\n", syntax );
      return 1;
   }
   else if ( shutdown( child_fd, SHUT_WR ) < 0 )
   {
      fprintf( stderr, "%s: shutdown(): %s.\n", syntax, strerror( errno ));
      return 1;
   }

   child_eof = 1;
   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_crypt( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *obj;
      char *str, *encrypted;

      obj = stack_pop( stack );
      str = str_dup( obj->data.atom->data.string->string, obj->data.atom->data.string->length );
      encrypted = crypt( str, str );
      free( str );

      if ( encrypted == NULL )
      {
         fprintf( stderr, "%s: crypt: crypt() failed.\n", syntax );
         return 1;
      }

      stack_push( stack, make_atom_from_string( encrypted, -1 ) );
   }

   return 0;
}

int do_loop( char *syntax, struct object *args )
{
   struct object *ptr, *result = NULL;
   int i;

   if ( args == NULL )
   {
      fprintf( stderr, "%s: missing body.\n", syntax );
      return 1;
   }

   for( ; ; )
   {
      for( i = 1, ptr = args; ptr != NULL; ptr = ptr->next, ++i )
      {
         stack_push( stack, ptr );

         if ( evaluate() )
         {
            if ( next_iteration )
            {
               next_iteration = 0;
               stop = 0;
               thrown = NULL;
               break;
            }
            else
            {
               if ( !stop )
                  fprintf( stderr, "%s: error evaluating body expression %d.\n",
                           syntax, i );

               return 1;
            }
         }

         result = stack_pop( stack );
      }
   }

   /* not reached */

   stack_push( stack, result );

   return 0;
}

int do_date2days( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)3 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct date dt;
      struct object *obj;
      int days;

      obj = stack_pop( stack );
      dt.d = number( obj->data.atom );

      obj = stack_pop( stack );
      dt.m = number( obj->data.atom );

      obj = stack_pop( stack );
      dt.y = number( obj->data.atom );

      if ( dt.y < 0 )
      {
         fprintf( stderr, "%s: year value less than 0: %d.\n", syntax, dt.y );
         return 1;
      }
      else if ( dt.m > 12 || dt.m < 1 )
      {
         fprintf( stderr, "%s: month value out of range: %d.\n", syntax, dt.m );
         return 1;
      }
      else if ( dt.d < 1 )
      {
         fprintf( stderr, "%s: day value out of range: %d.\n", syntax, dt.d );
         return 1;
      }
      else if ( dt.m == 1 || dt.m == 3 || dt.m == 5 || dt.m == 7 ||
                dt.m == 8 || dt.m == 10 || dt.m == 12 )
      {
         if ( dt.d > 31 )
         {
            fprintf( stderr, "%s: day value out of range for month: %d.\n", syntax, dt.d );
            return 1;
         }
      }
      else if ( dt.d > 30 )
      {
         fprintf( stderr, "%s: day value out of range for month: %d.\n", syntax, dt.d );
         return 1;
      }

      if (( days = ndaysg( &dt )) < 0 )
      {
         fprintf( stderr, "%s: ndaysg() returned an error.\n", syntax );
         return 1;
      }

      stack_push( stack, make_atom_from_number( days ));
   }

   return 0;
}

int do_days2date( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct date dt;
      struct object *obj;

      obj = stack_pop( stack );

      if ( number( obj->data.atom ) < 0 )
      {
         fprintf( stderr, "%s: argument less than 0: %d.\n", syntax, number( obj->data.atom ));
         return 1;
      }

      if ( gdate( number( obj->data.atom ), &dt ) == NULL )
      {
         fprintf( stderr, "%s: dateg() returned an error.\n", syntax );
         return 1;
      }

      obj = make_object();
      setlist( obj->flags );

      obj->data.head = make_atom_from_number( dt.y );
      obj->data.head->next = make_atom_from_number( dt.m );
      obj->data.head->next->next = make_atom_from_number( dt.d );

      stack_push( stack, obj );
   }

   return 0;
}

int do_week( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *obj;
      int year, wk;

      obj = stack_pop( stack );

      if (( wk = week( number( obj->data.atom ), &year )) < 0 )
      {
         fprintf( stderr, "%s: week() returned an error.\n", syntax );
         return 1;
      }

      obj = make_object();
      setlist( obj->flags );

      obj->data.head = make_atom_from_number( year );
      obj->data.head->next = make_atom_from_number( wk );

      stack_push( stack, obj );
   }

   return 0;
}

int do_weekday( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      static char *dtable[] = { "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday" };
      struct object *obj;
      int wkday;

      obj = stack_pop( stack );

      if (( wkday = weekday( number( obj->data.atom ))) < 0 )
      {
         fprintf( stderr, "%s: weekday() returned an error.\n", syntax );
         return 1;
      }

      obj = make_object();
      setlist( obj->flags );

      obj->data.head = make_atom_from_number( ( wkday == 6 ? 0 : wkday % 6 + 1 ));
      obj->data.head->next = make_atom_from_string( dtable[ wkday ], -1 );

      stack_push( stack, obj );
   }

   return 0;
}

int do_date2time( char *syntax, struct object *args )
{
   int hour, min, sec;

   hour = min = sec = 0;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, 0 );
      return 1;
   }

   stack_push( stack, args );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, 0 );
      return 1;
   }

   if ( args->next == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 2, 0 );
      return 1;
   }

   stack_push( stack, args->next );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 2, 0 );
      return 1;
   }

   if ( args->next->next == NULL )
   {
      print_err( ERR_MISSING_ARG, syntax, 3, 0 );
      return 1;
   }

   stack_push( stack, args->next->next );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 3, 0 );
      return 1;
   }

   if ( args->next->next->next != NULL )
   {
      hour = 1;
      stack_push( stack, args->next->next->next );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 4, 0 );
         return 1;
      }

      if ( args->next->next->next->next != NULL )
      {
         min = 1;
         stack_push( stack, args->next->next->next->next );

         if ( evaluate() )
         {
            if ( !stop )
               print_err( ERR_EVAL, syntax, 5, 0 );
            return 1;
         }

         if ( args->next->next->next->next->next != NULL )
         {
            sec = 1;
            stack_push( stack, args->next->next->next->next->next );

            if ( evaluate() )
            {
               if ( !stop )
                  print_err( ERR_EVAL, syntax, 6, 0 );
               return 1;
            }

            if ( args->next->next->next->next->next->next != NULL )
            {
               print_err( ERR_MORE_ARGS, syntax, 6, 0 );
               return 1;
            }
         }
      }
   }

   {
      struct object *obj;
      char buffer[ 32 ];
      time_t t;
      struct tm tm, *lt;

      /* Use localtime to fill in tm.gmtoff */

      t = time( NULL );

      if (( lt = localtime( &t )) == NULL )
      {
         fprintf( stderr, "%s: localtime returned an error.\n", syntax );
         return 1;
      }

      tm = *lt;

      if ( sec )
      {
         obj = stack_pop( stack );

         if ( numberp( obj->flags ) == 0 )
         {
            print_err( ERR_ARG_TYPE, syntax, 6, ERR_FIXNUM );
            return 1;
         }

         tm.tm_sec = number( obj->data.atom );
      }
      else
         tm.tm_sec = 0;

      if ( min )
      {
         obj = stack_pop( stack );

         if ( numberp( obj->flags ) == 0 )
         {
            print_err( ERR_ARG_TYPE, syntax, 5, ERR_FIXNUM );
            return 1;
         }

         tm.tm_min = number( obj->data.atom );
      }
      else
         tm.tm_min = 0;

      if ( hour )
      {
         obj = stack_pop( stack );

         if ( numberp( obj->flags ) == 0 )
         {
            print_err( ERR_ARG_TYPE, syntax, 4, ERR_FIXNUM );
            return 1;
         }

         tm.tm_hour = number( obj->data.atom );
      }
      else
         tm.tm_hour = 0;

      tm.tm_isdst = -1;

      obj = stack_pop( stack );

      if ( numberp( obj->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 3, ERR_FIXNUM );
         return 1;
      }

      tm.tm_mday = number( obj->data.atom );

      obj = stack_pop( stack );

      if ( numberp( obj->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 2, ERR_FIXNUM );
         return 1;
      }

      tm.tm_mon = number( obj->data.atom ) - 1;

      obj = stack_pop( stack );

      if ( numberp( obj->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 1, ERR_FIXNUM );
         return 1;
      }

      tm.tm_year = number( obj->data.atom ) - 1900;

      if ( tm.tm_year < 70 )
      {
         fprintf( stderr, "%s: year value less than 1970: %d.\n", syntax, tm.tm_year + 1900 );
         return 1;
      }
      else if ( tm.tm_mon > 11 || tm.tm_mon < 0 )
      {
         fprintf( stderr, "%s: month value out of range: %d.\n", syntax, tm.tm_mon + 1 );
         return 1;
      }
      else if ( tm.tm_mday < 1 )
      {
         fprintf( stderr, "%s: day value out of range: %d.\n", syntax, tm.tm_mday );
         return 1;
      }
      else if ( tm.tm_mon == 0 || tm.tm_mon == 2 || tm.tm_mon == 4 || tm.tm_mon == 6 ||
                tm.tm_mon == 7 || tm.tm_mon == 9 || tm.tm_mon == 11 )
      {
         if ( tm.tm_mday > 31 )
         {
            fprintf( stderr, "%s: day value out of range for month: %d.\n", syntax, tm.tm_mday );
            return 1;
         }
      }
      else if ( tm.tm_mday > 30 )
      {
         fprintf( stderr, "%s: day value out of range for month: %d.\n", syntax, tm.tm_mday );
         return 1;
      }
      else if ( tm.tm_hour < 0 || tm.tm_hour > 23 )
      {
         fprintf( stderr, "%s: hour value out of range: %d.\n", syntax, tm.tm_hour );
         return 1;
      }
      else if ( tm.tm_min < 0 || tm.tm_min > 59 )
      {
         fprintf( stderr, "%s: minute value out of range: %d.\n", syntax, tm.tm_min );
         return 1;
      }
      else if ( tm.tm_sec < 0 || tm.tm_sec > 59 )
      {
         fprintf( stderr, "%s: seconds value out of range: %d.\n", syntax, tm.tm_sec );
         return 1;
      }

      if (( t = mktime( &tm )) < 0 )
      {
         fprintf( stderr, "%s: mktime() returned an error.\n", syntax );
         return 1;
      }

      snprintf( buffer, sizeof( buffer ), "%ld", ( long int)t );
      stack_push( stack, make_atom_from_string( buffer, -1 ));
   }

   return 0;
}

int broken_time( char *syntax, struct object *args, int utc )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *obj;
      struct tm *tm;
      time_t t;

      obj = stack_pop( stack );
      t = atol( obj->data.atom->data.string->string );

      if (( tm = ( utc ? gmtime( &t ) : localtime( &t ))) == NULL )
      {
         fprintf( stderr, "%s: %s returned an error.\n", syntax,
                  ( utc ? "gmtime()" : "localtime()" ));
         return 1;
      }

      obj = make_object();
      setlist( obj->flags );

      obj->data.head = make_atom_from_number( tm->tm_year + 1900 );
      obj->data.head->next = make_atom_from_number( tm->tm_mon + 1 );
      obj->data.head->next->next = make_atom_from_number( tm->tm_mday );
      obj->data.head->next->next->next = make_atom_from_number( tm->tm_hour );
      obj->data.head->next->next->next->next = make_atom_from_number( tm->tm_min );
      obj->data.head->next->next->next->next->next = make_atom_from_number( tm->tm_sec );

      stack_push( stack, obj );
   }

   return 0;
}

int do_localtime( char *syntax, struct object *args )
{
   return broken_time( syntax, args, 0 );
}

int do_utctime( char *syntax, struct object *args )
{
   return broken_time( syntax, args, 1 );
}

int do_month( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      static char *months[] = { "January", "February", "March", "April", "May", "June",
                                "July", "August", "September", "October", "November", "December" };
      struct object *obj;
      int m;

      obj = stack_pop( stack );
      m = number( obj->data.atom );

      if ( m < 1 || m > 12 )
      {
         fprintf( stderr, "%s: argument out of range: %d.\n", syntax, m );
         return 1;
      }

      stack_push( stack, make_atom_from_string( months[ m - 1 ], -1 ));
   }

   return 0;
}

int do_negate( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      int i;
      struct object *car;

      car = stack_pop( stack );
      i = number( car->data.atom );

      stack_push( stack, make_atom_from_number( -i ));
   }

   return 0;
}

int do_getpid( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ) )
      return 1;

   stack_push( stack, make_atom_from_number( ( int )getpid() ) );

   return 0;
}

int do_getppid( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   stack_push( stack, make_atom_from_number( ( int )getppid() ));

   return 0;
}

int do_setpgid( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      if ( setpgid( ( pid_t )number( car1->data.atom ), ( pid_t )number( car2->data.atom )) < 0 )
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      else
         stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_getpgrp( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   stack_push( stack, make_atom_from_number( getpgrp() ));

   return 0;
}

int do_tcgetpgrp( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   {
      pid_t pid;

      if ( isatty( 0 ) == 0 )
         stack_push( stack, make_atom_from_number( 0 ));
      else
      {
         pid = tcgetpgrp( 0 );

         if ( pid < 0 )
            stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         else
            stack_push( stack, make_atom_from_number( pid ));
      }
   }

   return 0;
}

int do_tcsetpgrp( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;

      car = stack_pop( stack );

      if ( isatty( 0 ) == 0 )
         stack_push( stack, make_atom_from_number( 0 ));
      else
      {
         if ( tcsetpgrp( 0, ( pid_t )number( car->data.atom ) ) < 0 )
            stack_push( stack, make_atom_from_string( strerror( errno ), -1 ) );
         else
            stack_push( stack, make_atom_from_number( 1 ));
      }
   }

   return 0;
}

int do_kill( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      if ( kill( ( pid_t )number( car1->data.atom ), number( car2->data.atom )) < 0 )
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ) );
      else
         stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_killpg( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car1, *car2;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      if ( killpg( ( pid_t )number( car1->data.atom ), number( car2->data.atom )) < 0 )
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ) );
      else
         stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_fork( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   stack_push( stack, make_atom_from_number( fork() ));

   return 0;
}

int pipe_fork( char *syntax, int wrt )
{
   int fd[ 2 ], pid, flag;

   if ( pipe( &fd[ 0 ] ) < 0 )
   {
      fprintf( stderr, "%s: pipe: %s.\n", syntax, strerror( errno ));
      return -1;
   }

   switch(( pid = fork() ))
   {
      case -1:
         close( fd[ 0 ] );
         close( fd[ 1 ] );
         fprintf( stderr, "%s: fork: %s.\n", syntax, strerror( errno ));
         return -2;

      case 0:
         if (( dup2( fd[ 1 ], !wrt )) < 0 )
         {
            fprintf( stderr, "%s (child): dup2: %s.\n", syntax, strerror( errno ));
            _exit( 1 );
         }

         close( fd[ 0 ] );
         close( fd[ 1 ] );
         return 0;

      default:
         close( fd[ 1 ] );

         if (( flag = dup( wrt )) < 0 )
         {
            close( fd[ 0 ] );
            fprintf( stderr, "%s: dup: %s.\n", syntax, strerror( errno ));
            return -1;
         }

         stack_push( descriptors[ wrt ], ( void *)flag );

         if ( wrt )
            fclose(( wrt == 1 ? stdout : stderr ));

         if ( dup2( fd[ 0 ], wrt ) < 0 )
         {
            close( fd[ 0 ] );
            close( ( int )stack_pop( descriptors[ wrt ] ));
            fprintf( stderr, "%s: dup2: %s.\n", syntax, strerror( errno ));
            return -1;
         }

         close( fd[ 0 ] );

         if ( wrt == 1 )
         {
            stdout = fdopen( wrt, "w" );
            if ( stdout == NULL )
            {
               fprintf( stderr, "%s: fdopen: %s.\n", syntax, strerror( errno ));
               return -1;
            }
         }
         else if ( wrt == 2 )
         {
            stderr = fdopen( wrt, "w" );
            if ( stderr == NULL )
            {
               fprintf( stdout, "%s: fdopen: %s.\n", syntax, strerror( errno ));
               return -1;
            }
         }
   }

   return pid;
}

int do_forkpipe( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      int i;
      struct object *car;

      car = stack_pop( stack );
      i = number( car->data.atom );

      if ( i < 0 || i > 2 )
      {
         fprintf( stderr, "%s: descriptor argument out of range: %d\n", syntax, i );
         return 1;
      }

      if (( i = pipe_fork( syntax, i )) == -1 )
         return 1;

      stack_push( stack, make_atom_from_number( i ));
   }

   return 0;
}

int do_wait( char *syntax, struct object *args )
{
   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, 0 );
      return 1;
   }

   if ( args->next )
   {
      if ( args->next->next )
      {
         print_err( ERR_MORE_ARGS, syntax, 2, 0 );
         return 1;
      }
   }

   stack_push( stack, args );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, 0 );

      return 1;
   }

   if ( args->next )
   {
      stack_push( stack, args->next );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 2, 0 );

         return 1;
      }
   }

   {
      int status;
      pid_t pid, i, opt;
      struct object *obj, *car1, *car2;

      car2 = ( args->next == NULL ? NULL : stack_pop( stack ));
      car1 = stack_pop( stack );

      if ( islist( car1->flags ) || numberp( car1->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 1, ERR_FIXNUM );
         return 1;
      }

      i = number( car1->data.atom );

      opt = 1;

      if ( car2 == NULL ||
           (( islist( car2->flags ) == 1 && car2->data.head == NULL ) ||
            ( islist( car2->flags ) == 0 && ( car2->data.atom == NULL ||
                                              car2->data.atom == empty->data.atom ))))
         opt = 0;

      opt = ( opt ? ( WUNTRACED | WNOHANG ) : WUNTRACED );

      if (( pid = waitpid( i, &status, opt )) < 0 )
      {
         if ( errno != ECHILD )
         {
            fprintf( stderr, "%s: %s.\n", syntax, strerror( errno ));
            return 1;
         }
      }

      obj = make_object();
      stack_push( stack, obj );
      setlist( obj->flags );
      obj->data.head = make_atom_from_number( pid );

      if ( pid == child_pid )
         child_pid = -1;

      if ( pid <= 0 )
      {
         obj->data.head->next = make_atom_from_symbol( "ECHILD" );
      }
      else if ( WIFEXITED( status ))
      {
         obj->data.head->next = make_atom_from_symbol( "EXITED" );
         obj->data.head->next->next = make_atom_from_number( WEXITSTATUS( status ) );
      }
      else if ( WIFSTOPPED( status ))
      {
         obj->data.head->next = make_atom_from_symbol( "STOPPED" );
         obj->data.head->next->next = make_atom_from_number( WSTOPSIG( status ));
      }
      else if ( WIFSIGNALED( status ))
      {
         obj->data.head->next = make_atom_from_symbol( "KILLED" );
         obj->data.head->next->next = make_atom_from_number( WTERMSIG( status ));
      }
   }

   return 0;
}

int do_zombies( char *syntax, struct object *args )
{
   stack_push( stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   zombies = 1;

   return 0;
}

int do_nozombies( char *syntax, struct object *args )
{
   stack_push( stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   zombies = 0;

   return 0;
}

int do_glob( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car, *result, **ptr;
      glob_t globby;
      char **path;
      int i;

      car = stack_pop( stack );

      if ( glob( car->data.atom->data.string->string,
                 GLOB_NOSORT | GLOB_MARK | GLOB_BRACE | GLOB_NOCHECK | GLOB_TILDE,
                 NULL, &globby ) )
      {
         fprintf( stderr, "%s: %s.\n", syntax, strerror( errno ));
         return 1;
      }

      result = make_object();
      setlist( result->flags );
      stack_push( stack, result );

      for( path = globby.gl_pathv,
           ptr = &result->data.head,
           i = globby.gl_matchc;

           i;

           --i, ++path, ptr = &( *ptr )->next )

         *ptr = make_atom_from_string( *path, -1 );

      globfree( &globby );
   }

   return 0;
}

int dup_std( char *syntax, int std )
{
   int fd;
   FILE *file;

   if (( fd = dup( std )) < 0 )
   {
      fprintf( stderr, "%s: dup: %s.\n", syntax, strerror( errno ));
      return -1;
   }

   stack_push( descriptors[ std ], ( void *)fd );
   fclose( ( std == 2 ? stderr : stdout ) );

   if ( std == 2 )
      stderr = NULL;
   else
      stdout = NULL;

   if ( dup2( ( std == 2 ? 1 : 2 ), std ) < 0 )
   {
      resume( syntax, std );
      fprintf( stderr, "%s: dup2: %s.\n", syntax, strerror( errno ));
      return 1;
   }

   file = fdopen( std, "w" );
   if ( file == NULL )
   {
      resume( syntax, std );
      fprintf( stdout, "%s: fdopen: %s.\n", syntax, strerror( errno ));
      return 1;
   }

   if ( std == 2 )
      stderr = file;
   else
      stdout = file;

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_stderr2stdout( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   return dup_std( syntax, 2 );
}

int do_stdout2stderr( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   return dup_std( syntax, 1 );
}

int nth( char *syntax, struct object *list, int i, int cdr )
{
   struct object *ptr, *obj;

   if ( list->data.head == NULL )
   {
      stack_push( stack, list );
      return 0;
   }

   if ( i < 0 )
   {
      fprintf( stderr, "%s: index must be >= 0: %d.\n", syntax, i );
      return 1;
   }

   if ( !i )
      stack_push( stack, ( cdr ? list : list->data.head ));
   else
   {
      for( ptr = list->data.head;
           ( ptr != NULL && i );
           --i, ptr = ptr->next )
         ;

      if ( i || ptr == NULL )
      {
         obj = make_object();
         setlist( obj->flags );
         stack_push( stack, obj );
         return 0;
      }

      if ( cdr )
      {
         obj = make_object();
         setlist( obj->flags );
         obj->data.head = ptr;

         stack_push( stack, obj );
      }
      else
         stack_push( stack, ptr );
   }

   return 0;
}

int do_nth( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_LIST );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      int i;
      struct object *car1, *car2;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      i = number( car2->data.atom );

      return nth( syntax, car1, i, 0 );
   }
}

int do_nthcdr( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_LIST );
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)2 );

   if ( check_args( syntax, args ))
      return 1;

   {
      int i;
      struct object *car1, *car2;

      car2 = stack_pop( stack );
      car1 = stack_pop( stack );

      i = number( car2->data.atom );

      return nth( syntax, car1, i, 1 );
   }
}

int do_reset_history( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   while( history->used )
      free( stack_pop( history ));

   history_ptr = 0;

   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_zombiesp( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   stack_push( stack, make_atom_from_number( zombies ));

   return 0;
}

int do_dec2hex( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *obj;
      char buffer[ 64 ];

      obj = stack_pop( stack );
      snprintf( buffer, sizeof( buffer ), "%X", number( obj->data.atom ));

      stack_push( stack, make_atom_from_string( buffer, -1 ) );
   }

   return 0;
}

int do_hex2dec( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *obj;
      int d, s;
      char *ptr;

      obj = stack_pop( stack );
      d = 0;
      s = 1;

      for( ptr = obj->data.atom->data.string->string +
                 obj->data.atom->data.string->length - 1;
           ptr >= obj->data.atom->data.string->string;
          --ptr )
         if ( ! isxdigit( *ptr ))
         {
            fprintf( stderr, "%s: non-hex digit(s) in string: %s.\n", syntax, obj->data.atom->data.string->string );
            return 1;
         }
         else
         {
            switch( *ptr )
            {
               case 'a':
               case 'A':
                  d += s * 10;
                  break;

               case 'b':
               case 'B':
                  d += s * 11;
                  break;

               case 'c':
               case 'C':
                  d += s * 12;
                  break;

               case 'd':
               case 'D':
                  d += s * 13;
                  break;

               case 'e':
               case 'E':
                  d += s * 14;
                  break;

               case 'f':
               case 'F':
                  d += s * 15;
                  break;

               default:
                  d += s * ( *ptr - 48 );
            }

            s *= 16;
         }

      stack_push( stack, make_atom_from_number( d ));
   }

   return 0;
}

int do_listen( char *syntax, struct object *args )
{
   struct object *car1, *car2;
   struct sockaddr_in serv_addr;
   int fd, one = 1;

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 0, 0 );
      return 1;
   }

   if ( args->next != NULL )
   {
      car2 = args->next;

      if ( args->next->next != NULL )
      {
         print_err( ERR_MORE_ARGS, syntax, 2, 0 );
         return 1;
      }
   }
   else
      car2 = NULL;

   stack_push( stack, args );

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 1, 0 );

      return 1;
   }

   if ( car2 != NULL )
   {
      stack_push( stack, args->next );

      if ( evaluate() )
      {
         if ( !stop )
            print_err( ERR_EVAL, syntax, 2, 0 );

         return 1;
      }

      car2 = stack_pop( stack );
   }

   car1 = stack_pop( stack );

   if ( islist( car1->flags ) || numberp( car1->flags ) == 0 )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ERR_FIXNUM );
      return 1;
   }

   if ( car2 != NULL &&
        ( islist( car2->flags ) || numberp( car2->flags ) ||
          type( car2->data.atom->flags ) != ATOM_STRING ))
   {
      print_err( ERR_ARG_TYPE, syntax, 2, ERR_STRING );
      return 1;
   }

   if ( serv_fd >= 0 )
   {
      stack_push( stack, make_atom_from_string( "already listening", -1 ));
      return 0;
   }

   fd = socket( PF_INET, SOCK_STREAM, 0 );

   if ( fd == -1 )
   {
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return 0;
   }

   setsockopt( fd, SOL_SOCKET, SO_REUSEADDR, &one, sizeof( one ));

   bzero( &serv_addr, sizeof( serv_addr ));

   serv_addr.sin_family = AF_INET;

   if ( car2 == NULL )
      serv_addr.sin_addr.s_addr = htonl(  INADDR_ANY );
   else
   {
      int result;

      result = inet_aton( car2->data.atom->data.string->string,
                          ( struct in_addr *)&serv_addr.sin_addr.s_addr );

      if ( !result )
      {
         stack_push( stack, make_atom_from_string( "badly-formed address string", -1 ));
         return 0;
      }
      else if ( result < 0 )
      {
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 0;
      }
   }

   serv_addr.sin_port = htons( number( car1->data.atom ));

   if ( bind( fd, ( struct sockaddr *)&serv_addr, sizeof( serv_addr )) < 0 )
   {
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return 0;
   }

   if ( listen( fd, 30 ) < 0 )
   {
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return 0;
   }

   serv_fd = fd;

   stack_push( stack, make_atom_from_number( ntohs( serv_addr.sin_port )));

   return 0;
}

int do_accept( char *syntax, struct object *args )
{
   struct sockaddr_in client_addr;
   int dupin, dupout, fd;
   socklen_t client_len;

   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( serv_fd < 0 )
   {
      stack_push( stack, make_atom_from_string( "\"listen\" has not been invoked", -1 ));
      return 0;
   }

   client_len = sizeof( client_addr );

AGAIN:
   if (( fd = accept( serv_fd, ( struct sockaddr *)&client_addr, &client_len )) < 0 )
   {
      if ( errno == EAGAIN || errno == EINTR )
         goto AGAIN;

      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      close( serv_fd );
      serv_fd = -1;
      return 0;
   }

   if (( dupin = dup( 0 )) < 0 )
   {
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return 0;
   }

   if (( dupout = dup( 1 )) < 0 )
   {
      close( dupin );
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return 0;
   }

   stack_push( descriptors[ 0 ], ( struct atom *)dupin );
   stack_push( descriptors[ 1 ], ( struct atom *)dupout );

   fclose( stdout );
   stdout = NULL;

   if ( dup2( fd, 0 ) < 0 )
   {
      close( fd );
      resume( syntax, 0 );
      resume( syntax, 1 );
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return 0;
   }

   if ( dup2( fd, 1 ) < 0 )
   {
      close( fd );
      resume( syntax, 0 );
      resume( syntax, 1 );
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return 0;
   }

   close( fd );
   stdout = fdopen( 1, "w" );

   if ( stdout == NULL )
   {
      resume( syntax, 0 );
      resume( syntax, 1 );
      stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      return 0;
   }

   stack_push( stack, make_atom_from_number( 1 ));
   return 0;
}

int do_daemonize( char *syntax, struct object *args )
{
   struct object *car;

   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 0;

   car = stack_pop( stack );

   /*
    * Close any open full-duplex connection.
    */

   if ( child_fd >= 0 )
   {
      do_child_close( syntax, NULL );
      stack_pop( stack );
   }

   /*
    * Close shadowed open descriptors.
    */

   close_descriptors();

   /*
    * Close the standard descriptors now that all
    * redirections have been undone.
    */

   fclose( stdout );
   fclose( stderr );
   close( 0 );

   /*
    * Reopen the standard streams on /dev/null.
    */

   stdin = fopen( "/dev/null", "r" );
   stdout = fopen( "/dev/null", "w" );
   stderr = fopen( "/dev/null", "w" );

   syslog_name = str_dup( car->data.atom->data.string->string,
                          car->data.atom->data.string->length );

   openlog( syslog_name, LOG_PID, LOG_DAEMON );

   if ( stdin == NULL || stdout == NULL || stderr == NULL )
   {
      syslog( LOG_CRIT, "Cannot open one or more of the standard streams onto /dev/null." );
      exit( 1 );
   }

   /*
    * Fork and led the parent die, continuing as child so we are not
    * a process group leader.  This is necessary for the call to setsid().
    */

   switch( fork() )
   {
      case -1:
         syslog( LOG_CRIT, "Cannot fork." );
         exit( 1 );

      case 0:
         break;

      default:
         exit( 0 );
   }

   do_block( syntax, NULL );
   stack_pop( stack );

   if ( setsid() < 0 )
   {
      syslog( LOG_CRIT, "setsid() failed." );
      exit( 1 );
   }

   umask( 0 );

   isdaemon = 1;
   stack_push( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_syslog( char *syntax, struct object *args )
{
   struct object *car1, *car2;

   if ( args == NULL )
   {
      syslog( LOG_CRIT, "%s: missing arguments.\n", syntax );
      exit( 1 );
   }

   if ( args->next == NULL )
   {
      syslog( LOG_CRIT, "%s: missing argument 2.\n", syntax );
      exit( 1 );
   }

   if ( args->next->next != NULL )
   {
      syslog( LOG_CRIT, "%s: called with more than 2 arguments.\n", syntax );
      exit( 1 );
   }

   if ( !isdaemon )
   {
      stack_push( stack, make_atom_from_string( "\"daemonize\" has not been invoked", -1 ));
      return 0;
   }

   stack_push( stack, args );

   if ( evaluate() )
   {
      if ( !stop )
         syslog( LOG_CRIT, "%s: evaluation of argument 1 failed.\n", syntax );

      exit( 1 );
   }

   stack_push( stack, args->next );

   if ( evaluate() )
   {
      if ( !stop )
         syslog( LOG_CRIT, "%s: evaluation of argument 2 failed.\n", syntax );

      exit( 1 );
   }

   car2 = stack_pop( stack );
   car1 = stack_pop( stack );

   if ( islist( car1->flags ) || numberp( car1->flags ) ||
        type( car1->data.atom->flags ) != ATOM_SYMBOL )
   {
      syslog( LOG_CRIT, "%s: argument 1 did not evaluate to a symbol.\n", syntax );
      exit( 1 );
   }

   if ( islist( car2->flags ) || numberp( car2->flags ) ||
        type( car2->data.atom->flags ) != ATOM_STRING )
   {
      syslog( LOG_CRIT, "%s: argument 2 did not evaluate to a string.\n", syntax );
      exit( 1 );
   }

   {
      char *ptr;
      struct string *msg;
      int level;

      if( !strcmp( car1->data.atom->syntax, "ALERT" ))
         level = LOG_ALERT;
      else if ( !strcmp( car1->data.atom->syntax, "CRITICAL" ))
         level = LOG_CRIT;
      else if ( !strcmp( car1->data.atom->syntax, "ERROR" ))
         level = LOG_ERR;
      else if ( !strcmp( car1->data.atom->syntax, "WARNING" ))
         level = LOG_WARNING;
      else if ( !strcmp( car1->data.atom->syntax, "NOTICE" ))
         level = LOG_NOTICE;
      else if ( !strcmp( car1->data.atom->syntax, "INFO" ))
         level = LOG_INFO;
      else if ( !strcmp( car1->data.atom->syntax, "DEBUG" ))
         level = LOG_DEBUG;
      else
      {
         syslog( LOG_CRIT, "%s: Unrecognized level: %s", syntax, car1->data.atom->syntax );
         return 1;
      }

      msg = make_string();

      for( ptr = car2->data.atom->data.string->string; *ptr; ++ptr )
      {
         if ( *ptr == '%' )
            string_append( msg, *ptr );

         string_append( msg, *ptr );
      }

      syslog( level, msg->str );
      string_free( msg );
   }

   return 0;
}

int do_stop_listening( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( serv_fd >= 0 )
   {
      close( serv_fd );
      serv_fd = -1;
      stack_push( stack, make_atom_from_number( 1 ));
   }
   else
      stack_push( stack, make_atom_from_number( 0 ));

   return 0;
}

int do_base64_encode( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      unsigned int len, pad, i;
      char *ptr, buff[ 3 ], *trailer;
      struct string *s;
      static char *encs = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
                          "abcdefghijklmnopqrstuvwxyz"
                          "0123456789+/";

      car = stack_pop( stack );
      len = car->data.atom->data.string->length;

      if ( !len )
      {
         stack_push( stack, empty );
         return 0;
      }

      s = make_string();
      string_append( s, '"' );
      pad = len % 3;

      ptr = car->data.atom->data.string->string;

      if ( len > 2 )
      {
         len -= pad;

         for( i = 0; i < len; i += 3 )
         {
            buff[ 0 ] = *ptr++;
            buff[ 1 ] = *ptr++;
            buff[ 2 ] = *ptr++;

            string_append( s, encs[ ( buff[ 0 ] & 0xfc ) >> 2 ] );
            string_append( s, encs[ (( buff[ 0 ] & 0x03 ) << 4 ) + (( buff[ 1 ] & 0xf0 ) >> 4 ) ] );
            string_append( s, encs[ (( buff[ 1 ] & 0x0f ) << 2 ) + (( buff[ 2 ] & 0xc0 ) >> 6 ) ] );
            string_append( s, encs[ buff[ 2 ] & 0x3f ] );
         }
      }
      else
         pad = len;

      if ( pad )
      {
         buff[ 0 ] = *ptr++;
         string_append( s, encs[ ( buff[ 0 ] & 0xfc ) >> 2 ] );

         if ( --pad )
         {
            trailer = "=";
            buff[ 1 ] = *ptr;

            string_append( s, encs[ (( buff[ 0 ] & 0x03 ) << 4 ) + (( buff[ 1 ] & 0xf0 ) >> 4 ) ] );
            string_append( s, encs[ (( buff[ 1 ] & 0x0f ) << 2 ) ] );
         }
         else
         {
            trailer = "==";
            string_append( s, encs[ (( buff[ 0 ] & 0x03 ) << 4 ) ] );
         }

         for( ptr = trailer; *ptr; ++ptr )
            string_append( s, *ptr );
      }

      stack_push( stack, make_atom_directly_from_string( s->str, s->used ));
      free( s );
   }

   return 0;
}

int do_base64_decode( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      unsigned int i, pad;
      char buff[ 4 ], *ptr;
      struct string *s;

      car = stack_pop( stack );

      if ( car->data.atom->data.string->length % 4 )
      {
         stack_push( stack, make_atom_from_number( 0 ));
         return 0;
      }

      s = make_string();
      string_append( s, '"' );

      for( ptr = car->data.atom->data.string->string; *ptr; )
      {
         pad = 0;

         for( i = 0; i < 4; ++i, ++ptr )
         {
            if ( *ptr >= 'A' && *ptr <= 'Z' )
               buff[ i ] = *ptr - 65;
            else if ( *ptr >= 'a' && *ptr <= 'z' )
               buff[ i ] = *ptr - 97 + 26;
            else if ( *ptr >= '0' && *ptr <= '9' )
               buff[ i ] = *ptr - 48 + 52;
            else if ( *ptr == '+' )
               buff[ i ] = 62;
            else if ( *ptr == '/' )
               buff[ i ] = 63;
            else if ( *ptr == '=' )
            {
               buff[ i ] = 0;
               ++pad;
            }
            else
            {
               string_free( s );
               stack_push( stack, make_atom_from_number( 0 ));
               return 0;
            }
         }

         buff[ 0 ] <<= 2;
         buff[ 0 ] += ( buff[ 1 ] & 0x30 ) >> 4;
         buff[ 1 ] <<= 4;
         buff[ 1 ] += ( buff[ 2 ] & 0x3c ) >> 2;
         buff[ 2 ] <<= 6;
         buff[ 2 ] += buff[ 3 ];

         pad = 3 - pad;

         for( i = 0; i < pad; ++i )
            string_append( s, buff[ i ] );
      }

      stack_push( stack, make_atom_directly_from_string( s->str, s->used ));
      free( s );
   }

   return 0;
}

int do_eval_string( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      int i;

      /*
       * Leave the string object on the stack so that it will be found
       * during garbage collection, and left alone.
       */

      car = *stack->top;
      i = stack->used;

      stack_push( string_stack, ( void *)car->data.atom->data.string->string );
      --string_counter;

      for( ; ; )
      {
         int depth;

         depth = parse( string_counter );

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

         if ( evaluate() )
            break;

         car = stack_pop( stack );
      }

      while( input_stack->used )
         stack_pop( input_stack );

      /*
       * Remove the argument string.
       */

      stack_pop( stack );

      get_token( 0, -1 );
      ++string_counter;

      stack_push( stack, car );
   }

   return 0;
}

int do_flush_stdout( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   fflush( stdout );

   stack_push( stack, make_atom_from_number( 1 ));
   return 0;
}

int do_getpeername( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( serv_fd < 0 )
   {
      fprintf( stderr, "%s:  \"listen\" has not been invoked.\n", syntax );
      return 1;
   }

   {
      struct sockaddr_in addr;
      socklen_t len;
      char address[ 16 ];

      len = sizeof( struct sockaddr_in );

      if ( getpeername( 0, ( struct sockaddr *)&addr, &len ) < 0 )
      {
         stack_push( stack, make_atom_from_number( 0 ));
         return 0;
      }

      if ( inet_ntop( AF_INET, &addr.sin_addr, address, sizeof( address )) == NULL )
      {
         stack_push( stack, make_atom_from_number( 0 ));
         return 0;
      }

      stack_push( stack, make_atom_from_string( address, -1 ));
   }

   return 0;
}

int do_temporary( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   {
      char filename[] = "/tmp/mungerXXXXXXXXXX";
      int fd, dupout;

      if (( fd = mkstemp( filename )) < 0 )
      {
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 0;
      }

      if (( dupout = dup( 1 )) < 0 )
      {
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 0;
      }

      stack_push( descriptors[ 1 ], ( struct atom *)dupout );

      fclose( stdout );
      stdout = NULL;

      if ( dup2( fd, 1 ) < 0 )
      {
         close( fd );
         resume( syntax, 1 );
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 0;
      }

      close( fd );
      stdout = fdopen( 1, "w" );

      if ( stdout == NULL )
      {
         resume( syntax, 1 );
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
         return 0;
      }

      stack_push( stack, make_atom_from_string( filename, -1 ));
   }

   return 0;
}

int get_token_from_buffer( char *syntax, int buff )
{
   static char *ptr = NULL, *orig = NULL;
   static int line = 0;
   static int escape = 0;
   int type, result;

   if ( buff < 0 )
   {
      if ( orig != NULL )
         free( orig );

      ptr = orig = NULL;
      line = 0;
      return 0;
   }

   type = -1;
   string_truncate( token );

   for( ; ; )
   {
      if ( ptr == NULL || *ptr == 0 )
      {
         ++line;

         if ( orig != NULL )
         {
            free( orig );
            ptr = orig = NULL;
         }

         dbt_key.data = &key_data;
         dbt_key.size = sizeof( recno_t );

         if (( result = (( DB *)buffer_stack->values[ buff ] )->seq(
                            ( DB *)buffer_stack->values[ buff ], &dbt_key, &dbt_value, R_LAST )) == -1 )
         {
            fprintf( stderr, "%s: db->seq: %s.\n", syntax, strerror( errno ));
            return TOK_END;
         }
         else if ( result == 1 || line > ( int )dbt_key.data )
         {
            line = 0;

            if ( type >= 0 )
               return type;

            return ( type = TOK_END );
         }
         else
         {
            key_data = line;
            dbt_key.data = &key_data;
            dbt_key.size = sizeof( recno_t );

            if (( result = (( DB *)buffer_stack->values[ buff ] )->get(
                            ( DB *)buffer_stack->values[ buff ], &dbt_key, &dbt_value, 0 )) < 0 )
            {
               fprintf( stderr, "%s: db->get: %s.\n", syntax, strerror( errno ));
               line = 0;
               return TOK_END;
            }
            else if ( result == 1 )
            {
               line = 0;
               return TOK_END;
            }

            ptr = orig = str_dup( dbt_value.data, dbt_value.size );
         }
      }

      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 parse_buffer( char *syntax, int buff )
{
   int depth = 0;

   for( ; ; )
   {
      int type;

      type = get_token_from_buffer( syntax, buff );

      if ( type == TOK_END )
         return 1;

      depth = process_token( type, depth );

      if ( depth <= 0 )
         break;
   }

   return depth;
}

int do_eval_buffer( char *syntax, struct object *args )
{
   static int running = 0;

   stack_push( arg_stack, ( void *)0 );

   if ( check_args( syntax, args ))
      return 1;

   if ( running )
   {
      stack_push( stack, make_atom_from_number( 0 ));
      return 0;
   }

   running = 1;

   if ( do_lastline( syntax, NULL ))
      return 1;

   {
      struct object *car;
      int last, count, i;

      car = stack_pop( stack );
      last = number( car->data.atom );

      if ( !last )
      {
         stack_push( stack, make_atom_from_number( 0 ));
         return 0;
      }

      for( i = 0; i < buffer_stack->used; ++i )
         if ( buffer == buffer_stack->values[ i ] )
            break;

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

         depth = parse_buffer( syntax, i );

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

         if ( evaluate() )
         {
            if ( !stop )
               fprintf( stderr, "%s: evaluation of expression %d in buffer %d "
                                "failed.\n", syntax, count, i );

            get_token_from_buffer( syntax, -1 );
            running = 0;
            return 1;
         }

         car = stack_pop( stack );
      }

      get_token_from_buffer( syntax, -1 );
      running = 0;

      stack_push( stack, car );
   }

   return 0;
}

int do_chroot( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;

      car = stack_pop( stack );

      if ( chroot( car->data.atom->data.string->string ) < 0 )
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      else
         stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_setgid( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      struct group *group;

      car = stack_pop( stack );

      if (( group = getgrnam( car->data.atom->data.string->string )) == NULL )
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      else if ( setgid( group->gr_gid ) < 0 )
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      else
         stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_setegid( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_STRING );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      struct group *group;

      car = stack_pop( stack );

      if (( group = getgrnam( car->data.atom->data.string->string )) == NULL )
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      else if ( setegid( group->gr_gid ) < 0 )
         stack_push( stack, make_atom_from_string( strerror( errno ), -1 ));
      else
         stack_push( stack, make_atom_from_number( 1 ));
   }

   return 0;
}

int do_getline_ub( char *syntax, struct object *args )
{
   if ( args != NULL )
   {
      if ( args->next == NULL )
      {
         stack_push( arg_stack, ( void *)ERR_FIXNUM );
         stack_push( arg_stack, ( void *)1 );

         if ( check_args( syntax, args ))
            return 1;
      }
      else if ( args->next->next == NULL )
      {
         stack_push( arg_stack, ( void *)ERR_FIXNUM );
         stack_push( arg_stack, ( void *)ERR_FIXNUM );
         stack_push( arg_stack, ( void *)2 );

         if ( check_args( syntax, args ))
            return 1;
      }
      else
      {
         print_err( ERR_MORE_ARGS, syntax, 0, -1 );
         return 1;
      }
   }

   {
      int timeout, r, limit, count;
      char c;
      struct string *s;
      struct itimerval value;

      timeout = 0;
      limit = INT_MAX;

      if ( args != NULL )
      {
         struct object *ptr;

         if ( args->next != NULL )
         {
            ptr = stack_pop( stack );
            limit = number( ptr->data.atom );

            if ( limit <= 0 )
            {
               fprintf( stderr, "%s: limit value <= 0: %d.\n",
                        syntax, limit );
               return 1;
            }
         }

         ptr = stack_pop( stack );
         timeout = number( ptr->data.atom );

         if ( timeout < 0 )
         {
            fprintf( stderr, "%s: timeout value < 0: %d.\n",
                     syntax, timeout );
            return 1;
         }
      }

      s = make_string();
      string_append( s, '"' );

      count = 0;

AGAIN:
      for( ; ; )
      {
         if ( timeout )
         {
            value.it_interval.tv_sec = 0;
            value.it_interval.tv_usec = 0;
            value.it_value.tv_sec = timeout;
            value.it_value.tv_usec = 0;

            setitimer( ITIMER_REAL, &value, NULL );
         }

         if (( r = read( 0, &c, 1 )) <= 0 )
            break;

         string_append( s, c );

         if ( c == 10 || ++count == limit )
            break;
      }

      if ( timeout )
      {
         value.it_value.tv_sec = 0;
         value.it_value.tv_usec = 0;
         setitimer( ITIMER_REAL, &value, NULL );
      }

      if ( r < 0 )
      {
         if ( sigalrm )
         {
            /*
             * Will always be empty string when reading from a terminal in
             * canonical mode because we won't get any data until a
             * carriage return is entered.
             */

            stack_push( stack, make_atom_directly_from_string( s->str, s->used ));
            sigalrm = 0;
            free( s );
         }
         else if ( errno == EINTR || errno == EAGAIN )
            goto AGAIN;
         else
         {
            stack_push( stack, make_atom_from_number( 0 ));
            string_free( s );
         }
      }
      else if ( ! r )
      {
         if ( s->used > 1 )
         {
            stack_push( stack, make_atom_directly_from_string( s->str, s->used ));
            free( s );
         }
         else
         {
            string_free( s );
            stack_push( stack, make_atom_from_number( 0 ));
         }
      }
      else
      {
         stack_push( stack, make_atom_directly_from_string( s->str, s->used ));
         free( s );
      }
   }

   return 0;
}

int do_isatty( char *syntax, struct object *args )
{
   stack_push( arg_stack, ( void *)ERR_FIXNUM );
   stack_push( arg_stack, ( void *)1 );

   if ( check_args( syntax, args ))
      return 1;

   {
      struct object *car;
      int n;

      car = stack_pop( stack );
      n = number( car->data.atom );

      if ( n < 0 || n > 2 )
      {
         fprintf( stderr, "%s: descriptor out of range: %d.\n", syntax, n );
         return 1;
      }

      stack_push( stack, make_atom_from_number( isatty( n )));
   }

   return 0;
}