/*
 * Copyright (c) 2001-2026 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.
 */

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

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

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

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

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

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

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

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 )
{
   long int i, max = 1, cols, rows, total, column, target, width;
   char mask[ 32 ], *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 ].ptr;
      if ( s->used > max )
         max = s->used;
   }

   ++max;

   do_cols( "format_possibilities", NULL );
   width = ( *( struct object **)stack->top )->data.number;
   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 ), "%%-%lds ", 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 ].ptr;
         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 = lengths->values[ i ].integer;

      if ( l > max )
         max = l;
   }

   ++max;

   do_cols( "format_possibilities", NULL );
   width = ( *( struct object **)stack->top )->data.number;
   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 ].ptr;
         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 ].ptr;
      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 ].ptr;
            if ( s->used < min )
               min = s->used;
         }

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

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

               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 ].ptr;
            if ( strcmp( s->str, "../" ) && strcmp( s->str, "./" ))
               STACK_PUSH( e2, s )
         }

         if ( e2->used == 1 )
         {
            s = ( struct string *)e2->values[ 0 ].ptr;
            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 ].ptr,
                     lengths->values[ 0 ].integer );
      return p;
   }

   {
      int j, k, min = MAXNAMLEN;

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

         if ( l < min )
            min = l;
      }

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

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

            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 ].ptr;

      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 ].ptr );

            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 ].ptr;
         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;
}

/*
 * This function has been uglified by having evaluate() inlined into it.
 */

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

   total = *proto;

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

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

   idx = 1;
   ptr = args;
   count = 0;

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

      if ( idx > total )
         break;

      type = proto[ idx++ ];
      STACK_PUSH( stack, ptr )

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

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

             ||

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

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

            value = NULL;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

               if ( evaluate() )
                  return 1;

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

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

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

            switch( t )
            {
               case ATOM_INTRINSIC:

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

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

               case ATOM_CLOSURE:

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

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

               case ATOM_MACRO:

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

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

               default:
                  func_err( car );
                  return 1;
            }

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

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

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

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

         DONE:
            if ( result )
            {
               if ( !stop )
                  print_err( ERR_EVAL, syntax, 1, -1 );
               return 1;
            }
         }
      }

      item = stack->top->ptr;

      l = islist( item->flags );

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

      if ( ! ( type == -1 || (( type == ATOM_ATOM ) && !l ) || type == t ))
      {
         print_err( ERR_ARG_TYPE, syntax, count, type );
         return 1;
      }

      ptr = ptr->next;
   }

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

   return result;
}

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

   len = snprintf( buffer, sizeof( buffer ), "<RECORD#%d>", record_counter++ );
   entry = get_id( buffer, len, 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 ];
   int len;

   len = snprintf( buffer, sizeof( buffer ), "<STACK#%d>", stack_counter++ );
   entry = get_id( buffer, len, 1 );
   entry->flags = ATOM_STACK;
   entry->data.stack = stk;

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

   return object;
}

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

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

   return object;
}

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

   len = snprintf( buffer, sizeof( buffer ), "<DB#%d>", db_counter++ );
   entry = get_id( buffer, len, 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 )
{
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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, unsigned long int len )
{
   struct atom *entry;
   struct object *object;
   static struct string *new = NULL;

   if ( new == NULL )
      new = make_string();
   else
      STRING_TRUNCATE( new );

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

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

   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, unsigned long int len )
{
   struct atom *entry;
   struct object *object;

   entry = get_id( symbol, len, 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[ 64 ];
   int len;

   len = snprintf( buffer, sizeof( buffer ), "<REGEX#%d>", rx_counter++ );
   entry = get_id( buffer, len, 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 )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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(( long int ) winsize.ws_row ))
   }

   return 0;
}

int do_cols( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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(( long int ) winsize.ws_col ))
   }

   return 0;
}

int do_progn( char *syntax, struct object *args )
{
   int i = 0;

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

   if ( evaluate_body( args, &i ))
   {
      if ( !stop )
         fprintf( stderr, "%s: evaluation of body expression %d failed.\n", syntax, i );

      return 1;
   }

   return 0;
}

int do_cons( char *syntax, struct object *args )
{
   struct object *car1, *car2, *new, *new2;
   static int proto[] = { 2, -1, ATOM_LIST };

   if ( check_args( syntax, args, proto ))
      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;
   static int proto[] = { 1, ATOM_LIST };

   if ( check_args( syntax, args, proto ))
      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;
   static int proto[] = { 1, ATOM_LIST };

   if ( check_args( syntax, args, proto ))
      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;
   long int i;
   static int proto[] = { 2, -1, -1 };

   if ( check_args( syntax, args, proto ))
      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;
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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 *ptr, *ptr2, **ptr3;
   struct stack *stk;
   int i;

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

   stk = make_stack();

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

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

         stack_free( stk );
         return 1;
      }

      ptr2 = stack->top->ptr;

      if ( ! islist( ptr2->flags ))
      {
         print_err( ERR_ARG_TYPE, syntax, i, ATOM_LIST );
         stack_free( stk );
         return 1;
      }

      if ( ptr2->data.head == NULL )
         continue;

      STACK_PUSH( stk, ptr2 );
   }

   /*
    * Have to leave objects on stack during previous loop so garbage
    * collector may find them, if invoked as side-effect of calling
    * evaluate().
    */

   while( --i )
      STACK_POP( stack );

   /*
    * Can't duplicate objects until we are out of evaluation loop.
    * New objects would be reclaimed by GC, otherwise.  These two
    * loops cannot be coelesced into one.
    */

   if ( stk->used > 1 )
   {
      for( i = 0; i < stk->used - 1; ++i )
         stk->values[ i ].ptr = duplicate_object( stk->values[ i ].ptr );

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

         for( ptr3 = &ptr->data.head; *ptr3 != NULL; ptr3 = &( *ptr3 )->next )
            ;

         *ptr3 = (( struct object *)stk->values[ i + 1 ].ptr )->data.head;
      }
   }

   /*
    * stk->used can be zero if all the argument lists were empty lists.
    */

   if ( stk->used )
      STACK_PUSH( stack, stk->values[ 0 ].ptr )
   else
   {
      ptr = make_object();
      ptr->data.head = NULL;
      setlist( ptr->flags );
      stack_push( stack, ptr );
   }

   stack_free( stk );

   return 0;
}

int do_set( char *syntax, struct object *args )
{
   struct object *car1, *car2;
   static int proto[] = { 2, ATOM_SYMBOL, -1 };

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

   car2 = STACK_POP( stack );
   car1 = STACK_POP( stack );

   STACK_PUSH( stack, car2 )

   {
      struct stack *local;
      struct object *env_ptr;
      union stack_u *ptr;

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

         for( ptr = local->top; ptr > local->values; ptr -= 2 )
            if ( ptr->integer == car1->data.atom->id )
            {
               ( --ptr )->ptr = stack->top->ptr;
               return 0;
            }
      }

      insert_binding( car1->data.atom, stack->top->ptr );
   }

   return 0;
}

int do_eval( char *syntax, struct object *args )
{
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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 consequent expression.\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 ].ptr );
      ( *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 ), "%li", ptr->data.number );
         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, 1, len, ( 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 )
   {
      if (( islist( ptr->flags ) && ptr->data.head == NULL )
             ||
            ( islist( ptr->flags ) == 0 &&
              ( numberp( ptr->flags ) ||
                ptr->data.atom->id == lambda_id ||
                ptr->data.atom->id == macro_id  ||
                type( ptr->data.atom->flags ) != ATOM_SYMBOL )))
         do_print_objects_strings_unquoted( ptr, 0, 0 );
      else if ( islist( ptr->flags ) == 0 )
      {
         struct stack *local;
         struct object *env_ptr, *value;
         union stack_u *ptr2;

         value = NULL;

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

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

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

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

      FOUND_0:
         do_print_objects_strings_unquoted( value, 0, 0 );
      }
      else
      {
         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 )
   {
      if (( islist( ptr->flags ) && ptr->data.head == NULL )
             ||
            ( islist( ptr->flags ) == 0 &&
              ( numberp( ptr->flags ) ||
                ptr->data.atom->id == lambda_id ||
                ptr->data.atom->id == macro_id  ||
                type( ptr->data.atom->flags ) != ATOM_SYMBOL )))
         do_print_objects_strings_unquoted( ptr, 0, 0 );
      else if ( islist( ptr->flags ) == 0 )
      {
         struct stack *local;
         struct object *env_ptr, *value;
         union stack_u *ptr2;

         value = NULL;

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

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

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

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

      FOUND_0:
         do_print_objects_strings_unquoted( value, 0, 0 );
      }
      else
      {
         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 )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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;
   static int proto[] = { 1, ATOM_STRING };

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

   car = STACK_POP( stack );

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

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

   {
      struct termios termios = canon_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;
      }

      tty_mode = 0;
   }
}

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 ( ! isatty( 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 );
   tty_mode = 1;
}

int do_complete( char *syntax, struct object *args )
{
   struct object *car, **ptr, *result;
   struct stack *results;
   struct string *str;
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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[ 131072 ] = "", *ptr = buffer;
   int result;
   static int len = 0;
   static struct string *s = NULL;

   switch( reset )
   {
      case 1:
         STACK_PUSH( input_buffer_stack, str_dup( ptr, len ))
         STACK_PUSH_INT( input_buffer_stack, len )

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

      case 2:
         if ( input_buffer_stack->used )
         {
            len = STACK_POP_INT( 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;
   }

   if ( s == NULL )
      s = make_string();
   else
      STRING_TRUNCATE( s );

   STRING_APPEND( s, '"' )

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

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

            STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno  ))))
            return 0;
         }
         else if ( result == 0 )
         {
            len = 0;

            if ( s->used > 1 )
            {
               STACK_PUSH( stack, make_atom_directly_from_string( s->str, s->used ))
               free( s );
               s = NULL;
            }
            else
               STACK_PUSH( stack, make_atom_from_number( 0 ))

            return 0;
         }

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

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

         /*
          * The order of these tests is significant.  Previously the first
          * test was on the other side of the ||, causing the pointer increment
          * to not happen when long lines were encountered, screwing up the
          * next invocation of "getline".
          */

         if ( *ptr++ == 10 || s->used == 2048 )
            goto NEXT;
      }
   }

NEXT:
   STACK_PUSH( stack, make_atom_directly_from_string( s->str, s->used ))
   free( s );
   s = NULL;

   return 0;
}

int do_rescan_path( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 ].ptr )) == 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_INT( executables, (( int )dp->d_namlen ))
         STACK_PUSH( executables, ( char *)stk->values[ i ].ptr )
      }

      closedir( dir );
   }

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

   while( executables->used )
   {
      ptr2 = ( char *)STACK_POP( executables );
      j = STACK_POP_INT( executables );
      ptr = ( char *)STACK_POP( executables );

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

      if ( ptr != NULL )
      {
         STACK_PUSH( stk, ptr )
         STACK_PUSH_INT( stk, 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 )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 ].ptr ) == 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; ++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 ].ptr;

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

         if ( strncmp( ptr, input, len ) == 0 )
         {
            STACK_PUSH( stk, ptr )
            STACK_PUSH_INT( stk2, 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 ].ptr,
                                stk2->values[ 0 ].integer );
         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;

   while( s->used && ( s->str[ s->used - 1 ] == '\t' || s->str[ s->used - 1 ] == ' ' ))
      STRING_CHOP( s );

   while( s->used && ( s->str[ 0 ] == '\t' || s->str[ 0 ] == ' ' ))
      string_erase( s, 0 );

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

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

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

      tmp = history->values[ i ].ptr;

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

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

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

      history->values[ i ].ptr = 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;

   --history_ptr;

   return ( char *)history->values[ history_ptr ].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 ].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, struct stack *offsets )
{
   int len, idx, space, n;
   char *ptr;
   static struct string *working = NULL;

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

   idx = 0;

   for( n = 0, ptr = s->str; n < s->used; ++ptr, ++n )
      if ( *ptr != '\t' )
         STRING_APPEND( working, *ptr )
      else
      {
         len = offsets->values[ idx++ ].integer;
         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, ATOM_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, ATOM_FIXNUM);
            return 1;
         }
      }
   }

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

   {
      static struct string *s = NULL, *after = NULL, *clip = NULL, *search = NULL, *key = NULL;
      static struct stack *offsets = NULL;
      unsigned char c;

      char *name = NULL;

      long int tabstop, result, eof, was_canon, name_len, offset, esc;

      /*
       * 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 ( ce <= 0 || cm <= 0 )
         return getline_from_file( syntax, 0 );

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

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

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

      eof = 0;

      was_canon = tty_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;
      }

      if ( s == NULL )
         s = make_string();
      else
      {
         s->free += s->used;
         s->used = 0;
         s->top = s->str;
      }

      if ( key == NULL )
         key = make_string();
      else
      {
         key->free += key->used;
         key->used = 0;
         key->top = key->str;
      }

      if ( after == NULL )
         after = make_string();
      else
      {
         after->free += after->used;
         after->used = 0;
         after->top = after->str;
      }

      if ( clip == NULL )
         clip = make_string();
      else
      {
         clip->free += clip->used;
         clip->used = 0;
         clip->top = clip->str;
      }

      if ( search == NULL )
         search = make_string();
      else
      {
         search->free += search->used;
         search->used = 0;
         search->top = search->str;
      }

      if ( offsets == NULL )
         offsets = make_stack();
      else
      {
         offsets->free += offsets->used;
         offsets->used = 0;
         offsets->top = offsets->values;
      }

      offset = 0;
      esc = 0;

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

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

            if ( was_canon )
               canon( syntax );

            STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
            return 0;
         }
         else if ( result == 0 )
         {
            eof = 1;
            break;
         }

         if ( esc )
         {
            c += 128;
            esc = 0;
         }

   EXIT_SEARCH:
         switch( c )
         {
            case 27:
               esc = 1;
               goto AGAIN;
               break;

            /* 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 = STACK_POP_INT( 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;
                  STRING_TRUNCATE( s )
                  STRING_TRUNCATE( after )
               }
               break;

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

                  str = forw_history();

                  if ( str != NULL )
                     string_assign( s, str, strlen( str ));
                  else
                     STRING_TRUNCATE( s );
               }
               break;

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

                  str = back_history( );

                  if ( str != NULL )
                  {
                     string_assign( s, str, strlen( str ));
                     STRING_TRUNCATE( after )
                  }
               }
               break;

            /* C-r, C-s */
            case 18:
            case 19:
               if ( tabstop <= 0 )
               {
                  char *str = NULL;
                  int i, matched = 0, start_forw = 0;

                  if ( c == 19 )
                     ++start_forw;

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

                  STRING_TRUNCATE( after );
                  STRING_TRUNCATE( s );

                  string_assign( key, "[] ", 2 );

                  putp( tgoto( cm, 0, LINES - 2 ));
                  putp( ce );
                  fwrite( key->str, key->used, 1, stdout );

                  putp( tgoto( cm, 0, LINES - 1 ));
                  putp( ce );
                  fwrite( name, name_len, 1, stdout );

                  if ( history_ptr < history->used )
                  {
                     char *hist = ( char *)history->values[ history_ptr ].ptr;

                     while( *hist )
                        STRING_APPEND( s, *hist++ );

                     fputs( s->str, stdout );
                     putp( tgoto( cm, name_len, LINES -1 ));
                  }

                  fflush( stdout );

                  STRING_TRUNCATE( search );

                  for( ; ; )
                  {
                     result = read( 0, &c, 1 );

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

                        if ( was_canon )
                           canon( syntax );

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

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

                     switch( c )
                     {
                        case 3:
                           history_ptr = history->used;
                           STRING_TRUNCATE( s );
                           putp( tgoto( cm, 0, LINES - 2 ));
                           putp( ce );
                           putp( tgoto( cm, 0, LINES - 1 ));
                           putp( ce );
                           goto NEXT;
                           break;

                        case 10:
                        case 13:
                           history_ptr = history->used;
                           string_prepend( after, '\n' );
                           fwrite( "\r\n", 2, 1, stdout );
                           goto BREAK;

                        case 8:
                           STRING_CHOP( search )
                           if ( history_ptr != history->used && search->used &&
                                strstr(( char*)history->values[ history_ptr ].ptr, search->str ) != NULL )
                              matched = 1;
                           break;

                        case 18:
                           if ( start_forw )
                              --start_forw;
                           break;

                        case 19:
                           break;

                        default:
                           if ( c > 31 && c < 127 )
                           {
                              STRING_APPEND( search, c )

                              if ( history_ptr != history->used &&
                                   strstr(( char*)history->values[ history_ptr ].ptr, search->str ) != NULL )
                                 matched = 1;
                           }
                           else
                           {
                              if ( c != 14 && c != 16 )
                              {
                                 int i;

                                 for( i = s->used - 1; i >= 0; --i )
                                 {
                                    STRING_APPEND( after, s->str[ i ] )
                                    STRING_CHOP( s )
                                 }
                              }

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

                              goto EXIT_SEARCH;
                           }
                     }

                     string_assign( key, "[", 1 );

                     for( i = 0; i < search->used; ++i )
                        STRING_APPEND( key, search->str[ i ] )

                     STRING_APPEND( key, ']' );
                     STRING_APPEND( key, ' ' );

                     if ( search->used && ! matched )
                     {
                        if ( c == 19 || start_forw )
                        {
                           if (( str = forw_search_history( search->str )) == NULL )
                           {
                              history_ptr = -1;
                              str = forw_search_history( search->str );

                              if ( str == NULL )
                                 history_ptr = 0;
                           }
                        }
                        else if (( str = back_search_history( search->str )) == NULL )
                        {
                           history_ptr = history->used;
                           str = back_search_history( search->str );
                        }

                        if ( str != NULL )
                           string_assign( s, str, strlen( str ));
                     }

                     putp( tgoto( cm, 0, LINES - 2 ));
                     putp( ce );
                     fwrite( key->str, key->used, 1, stdout );

                     putp( tgoto( cm, 0, LINES - 1 ));
                     putp( ce );
                     fwrite( name, name_len, 1, stdout );
                     fwrite( s->str, s->used, 1, stdout );
                     putp( tgoto( cm, name_len, LINES - 1 ));
                     fflush( stdout );

                     matched = 0;
                  }
               }

            NEXT:
               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 = STACK_POP_INT( 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_INT( offsets, 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 && c < 127 )
                  STRING_APPEND( s, c )
               break;

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

   BREAK:
      if ( was_canon )
         canon( syntax );

      while( after->used )
      {
         string_append( s, *( after->top - 1 ));
         STRING_CHOP( 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;
         }
      }
   }

   return 0;
}

int do_fixnump( char *syntax, struct object *args )
{
   struct object *car;
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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 ) ? 1 : 0 )));

   return 0;
}

int do_stringp( char *syntax, struct object *args )
{
   struct object *car;
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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, ATOM_FIXNUM);
         return 1;
      }

      if ( car3->data.number <= 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, ATOM_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, ATOM_STRING );
      return 1;
   }

   {
      struct object *result;
      char *tmp1, *tmp2, *tmp3, *tmp4 = NULL, **results;
      long 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 ( car3->data.number <= length )
            arg3 = car3->data.number - 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, ATOM_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, ATOM_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, ATOM_STRING );
         return 0;
      }
      else if ( islist( result->flags ))
      {
         int j;

         if ( result->data.head == NULL )
         {
            print_err( ERR_ARG_TYPE, syntax, i + 1, ATOM_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, ATOM_STRING );
         return 0;
      }
   }

   return i;
}

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

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

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

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

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

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

      sep    = car1->data.atom->data.string->string;
      seplen = car1->data.atom->data.string->length;

      buffer = make_string();
      len    = 0;

      for( j = i - 1; j; --j )
      {
         item = stack->values[ stack->used - j ].ptr;
         len  += item->data.atom->data.string->length;

         if ( j != 1 )
            len += seplen;
      }

      if (( buffer->str = realloc( buffer->str, buffer->used + 2 + len )) == NULL )
      {
         fprintf( stderr, "%s: realloc: %s.\n", syntax, strerror( errno ));
         exit( 1 );
      }

      buffer->top  = &buffer->str[ buffer->used ];
      *buffer->top = '\0';
      buffer->free = len + 1;

      STRING_APPEND( buffer, '"' )

      for( j = i - 1; j; --j )
      {
         char *ptr1, *ptr2;

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

         for( ptr1 = tmp, ptr2 = buffer->top; len; ++ptr1, ++ptr2, --len )
         {
            *ptr2 = *ptr1;
            ++buffer->top;
            ++buffer->used;
            --buffer->free;
         }

         *buffer->top = '\0';

         if ( j != 1 )
         {
            len = seplen;
            tmp = sep;

            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;
   static struct string *buffer = NULL;
   regmatch_t matches[ 20 ];
   int result, length, i;
   char old;

   old = the_string[ len ];
   the_string[ len ] = '\0';

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

   the_string[ len ] = old;

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

   if ( buffer == NULL )
      buffer = make_string();
   else
      STRING_TRUNCATE( buffer );

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

   return 0;
}

int do_matches( char *syntax, struct object *args )
{
   struct object *car1, *car2;
   static int proto[] = { 2, ATOM_REGEXP, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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;
   static int proto[] = { 2, ATOM_REGEXP, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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, ATOM_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, ATOM_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, ATOM_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, ATOM_REGEXP );
      return 1;
   }

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

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

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

      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 = car1->data.head->data.number;
         end = car1->data.head->next->data.number;

         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[ strtol( c, NULL, 10 ) ];
                  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;
   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, ATOM_FIXNUM );
            return 1;
         }
      }

      car2 = STACK_POP( stack );

      if ( numberp( car2->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 2, ATOM_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, ATOM_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 || car3->data.number == 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 '>':
               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;

            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 ));
   flags = REG_EXTENDED;

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

   if ( car3 != NULL && car3->data.number )
   {
      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, ATOM_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, ATOM_STRING );
            return 1;
         }
      }
      else
      {
         if ( numberp( result->flags ) ==  0 )
         {
            print_err( ERR_ARG_TYPE, syntax, i, ATOM_FIXNUM );
            return 1;
         }
      }
   }

   items = make_stack();
   while( --i )
   {
      result = STACK_POP( stack );
      if ( type )
         STACK_PUSH( items, (( struct object *)result )->data.atom->data.string )
      else
         STACK_PUSH_INT( items, (( struct object *)result )->data.number )
   }

   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 ].ptr )->string,
            (( struct lstring *)items->values[ i ].ptr )->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( items->values[ i ].integer );
         ( *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;
   static int proto[] = { 1, ATOM_LIST };

   if ( check_args( syntax, args, proto ))
      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 ].ptr );
         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;
   static int proto[] = { 1, ATOM_LIST };

   if ( check_args( syntax, args, proto ))
      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_INT( items, ptr->data.number )
      }

      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 ].ptr )->string,
               (( struct lstring *)items->values[ i ].ptr )->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( items->values[ i ].integer );
            ( *ptr2 )->next = NULL;
            ptr2 = &( *ptr2 )->next;
         }
      }

      stack_free( items );
   }

   return 0;
}

int do_while( char *syntax, struct object *args )
{
   struct object *result;
   int old_stack, failed;

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

   old_stack = stack->used;

   for( ; ; )
   {
CONTINUE:
      STACK_PUSH( stack, args )

      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 ( evaluate_body( args->next, &failed ))
         {
            if ( !stop )
               fprintf( stderr, "%s: evaluation of body expression %d failed.\n", syntax, failed );

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

            return 1;
         }

         STACK_POP( stack );
      }
   }

   STACK_PUSH( stack, result )

   return 0;
}

int do_until( char *syntax, struct object *args )
{
   struct object *result;
   int old_stack, failed;

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

   old_stack = stack->used;

   for( ; ; )
   {
      STACK_PUSH( stack, args )

      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 ( evaluate_body( args->next, &failed ))
         {
            if ( !stop )
               fprintf( stderr, "%s: evaluation of body expression %d failed.\n", syntax, failed );

            if ( next_iteration )
            {
               next_iteration = 0;
               stop = 0;
               thrown = NULL;
               stack_truncate( stack, stack->used - old_stack );
               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 old_stack, failed;

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

   old_stack = stack->used;

   for( ; ; )
   {
      if ( evaluate_body( args, &failed) )
      {
         if ( !stop )
            fprintf( stderr, "%s: evaluation of body expression %d failed.\n", syntax, failed );

         if ( next_iteration )
         {
            next_iteration = 0;
            stop = 0;
            thrown = NULL;
            stack_truncate( stack, stack->used - old_stack );
            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 )
{
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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, ATOM_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 ), "%li", ptr->data.number );
         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;
   long int i;
   static int proto[] = { 1, ATOM_STRING };

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

   car = STACK_POP( stack );
   i = strtol( car->data.atom->data.string->string, NULL, 10 );
   STACK_PUSH( stack, make_atom_from_number( i ))

   return 0;
}

int do_intern( char *syntax, struct object *args )
{
   struct object *car;
   char *ptr;
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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,
                                             car->data.atom->data.string->length ))

   return 0;
}

int do_additive( char *syntax, struct object *args, int multiply )
{
   struct object *ptr, *result;
   long 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, ATOM_FIXNUM );
         return 1;
      }

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

      ++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;
   long int i1, i2, result = 0;
   static int proto[] = { 2, ATOM_FIXNUM, ATOM_FIXNUM };

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

   car2 = STACK_POP( stack );
   car1 = STACK_POP( stack );

   i1 = car1->data.number;
   i2 = car2->data.number;

   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 )
{
   long int result = 0, i1, i2;
   struct object *car1, *car2;
   static int proto[] = { 2, ATOM_FIXNUM, ATOM_FIXNUM };

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

   car2 = STACK_POP( stack );
   car1 = STACK_POP( stack );

   i1 = car1->data.number;
   i2 = car2->data.number;

   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;
   static int proto[] = { 1, ATOM_FIXNUM };

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

   car = STACK_POP( stack );
   STACK_PUSH( stack, make_atom_from_number( abs( car->data.number )))

   return 0;
}

int do_char( char *syntax, struct object *args )
{
   struct object *car;
   char s[ 2 ];
   int i;
   static int proto[] = { 1, ATOM_FIXNUM };

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

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

   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;
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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;
   void *ptr;
   mode_t mode;
   static int proto[] = { 0 };

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

   if (( ptr = setmode( "0600" )) == NULL )
   {
      fprintf( stderr, "%s: setmode(): %s.\n", syntax, strerror( errno ));
      return 1;
   }

   mode = getmode( ptr, 0 );
   free( ptr );

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 )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 ].ptr == buffer )
         {
            buffer_stack->values[ i ].ptr = NULL;
            hash_free( bookmark_stack->values[ i ].ptr, HASH_SIZE );
            free( bookmark_stack->values[ i ].ptr );
            bookmark_stack->values[ i ].ptr = NULL;
            break;
         }

      buffer = NULL;

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

      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_insert( char *syntax, struct object *args )
{
   struct object *car1, *car2, *car3;
   long int arg3, flag = 0, after_line;
   static int proto[] = { 3, ATOM_FIXNUM, ATOM_STRING, ATOM_FIXNUM };

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

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

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

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

   key_data = car1->data.number;
   after_line = key_data;

   arg3 = car3->data.number;

   if ( ! arg3 )
      flag = R_SETCURSOR;
   else if ( arg3 > 0 )
      flag = R_IAFTER;
   else
      flag = R_IBEFORE;

   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 ( arg3 )
      adjust_bookmarks(( arg3 < 0 ? after_line - 1 : after_line ), 1, -1 );

   return 0;
}

int do_delete( char *syntax, struct object *args )
{
   struct object *car;
   long int result, arg1;
   static int proto[] = { 1, ATOM_FIXNUM };

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

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

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

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

   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_lastline( char *syntax, struct object *args )
{
   long int result;
   static int proto[] = { 0 };

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

   if ( check_args( syntax, args, proto ))
      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;
   long int result;
   static int proto[] = { 1, ATOM_FIXNUM };

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

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

   car = STACK_POP( stack );
   key_data = car->data.number;

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

         close( fd );
         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;

            close( fd );
            string_free( s );

            fprintf( stderr, "%s: read: %s.\n", syntax, strerror( errno ));
            return 1;
         }
         else if ( result == 0 )
         {
            close( fd );
            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 );

                     close( fd );
                     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 )
            {
               close( fd );
               string_free( s );

               fprintf( stderr, "%s: db->get: %s.\n", syntax, strerror( errno ));
               return 1;
            }
            else if ( result == 1 )
            {
               close( fd );
               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, -1 );
   }

   if ( j > end )
      adjust_bookmarks( ( end ? begin : begin - 1 ), j - end, -1 );

   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 ];
   long int pid, beginning, ending, result;
   int fd[ 2 ];
   static int proto[] = { 3, ATOM_FIXNUM, ATOM_FIXNUM, ATOM_STRING };

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

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

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

   beginning = car1->data.number;
   ending = car2->data.number;

   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, ATOM_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;
      long int arg1, arg2, fd, i, flags, result, escape, create_empty;

      arg1 = car1->data.number;
      arg2 = car2->data.number;

      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 || car5->data.number == 0 )
         flags = ( O_CREAT | O_WRONLY );
      else
         flags = ( O_CREAT | O_APPEND | O_WRONLY );

      if ( car4->data.number == 1 )
         flags |= O_EXLOCK | O_NONBLOCK;
      else
         flags |= O_SHLOCK | O_NONBLOCK;

      if (( ptr = setmode( "0600" )) == NULL )
      {
         fprintf( stderr, "%s: setmode(): %s.\n", syntax, strerror( errno ));
         return 1;
      }

      mode = getmode( ptr, 0 );
      free( ptr );

   AGAIN:
      if (( fd = open( name, flags, mode )) < 0 )
      {
         if ( errno == EINTR )
            goto AGAIN;

         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
         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 || car5->data.number == 0 )
         if ( ftruncate( fd, 0 ))
         {
            close( fd );
            STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
            return 0;
         }

      if ( create_empty )
         STACK_PUSH( stack, make_atom_from_number( 0 ))
      else
      {
         char output_buffer[ 131072 ], *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 ), strlen( strerror( errno ))))
               return 0;
            }
            else if ( result == 1 )
            {
               close( fd );
               STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
               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 ), strlen( strerror( errno ))))
                  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 ), strlen( strerror( errno ))))
            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, escape, flags, count = 0, altered = 0;
   long int arg1;
   char *name, *ptr;
   static int proto[] = { 2, ATOM_FIXNUM, ATOM_STRING };

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

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

   car2 = STACK_POP( stack );
   car1 = STACK_POP( stack );

   arg1 = car1->data.number;

   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 | O_SHLOCK )) < 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 ), strlen( strerror( errno ))))
            break;
      }

      return 0;
   }

   s = make_string();

   for( ; ; )
   {
      int result;
      char *ptr;
      char input_buffer[ 131072 ];

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

   STACK_PUSH( stack, make_atom_from_number( count ))

   return 0;
}

int do_empty( char *syntax, struct object *args )
{
   int i, last;
   struct hash_elt **ptr, *ptr2;
   static int proto[] = { 0 };

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

   if ( check_args( syntax, args, proto ))
      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;
   }

   ptr = bookmarks;

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

      for( ptr2 = *ptr; ptr2 != NULL; ptr2 = ptr2->next )
         ptr2->element.integer = -1;

      ++ptr;
   }

   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;
   long int arg1, arg2, arg3, arg4, arg5;
   static int proto[] = { 5, ATOM_FIXNUM, ATOM_FIXNUM, ATOM_FIXNUM,
                             ATOM_FIXNUM, ATOM_FIXNUM };

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

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

   car5 = STACK_POP( stack );
   car4 = STACK_POP( stack );
   car3 = STACK_POP( stack );
   car2 = STACK_POP( stack );
   car1 = STACK_POP( stack );

   arg1 = car1->data.number;
   arg2 = car2->data.number;
   arg3 = car3->data.number;
   arg4 = car4->data.number;
   arg5 = car5->data.number;

   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;
   long 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;
   static int proto[] = { 5, ATOM_FIXNUM, ATOM_FIXNUM, ATOM_FIXNUM,
                          ATOM_REGEXP, ATOM_FIXNUM };

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

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

   car5 = STACK_POP( stack );
   car4 = STACK_POP( stack );
   car3 = STACK_POP( stack );
   car2 = STACK_POP( stack );
   car1 = STACK_POP( stack );

   arg5 = car5->data.number;
   arg1 = car1->data.number;

   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 = car2->data.number;
   start = arg2;

   arg3 = car3->data.number;

   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: %ld.\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;
   long int pipe, arg1, last, result, escape;
   int pid;
   char *name, *ptr;
   static int proto[] = { 2, ATOM_FIXNUM, ATOM_STRING };

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

   if ( check_args( syntax, args, proto ))
      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 = car1->data.number;

   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;
   long int i, result, escape, arg1, arg2;
   int pipe, pid;
   static int proto[] = { 3, ATOM_FIXNUM, ATOM_FIXNUM, ATOM_STRING };

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

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

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

   arg1 = car1->data.number;
   arg2 = car2->data.number;

   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;
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 0 };

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

   STACK_PUSH( stack, make_atom_from_number( LONG_MAX ))

   return 0;
}

int do_chdir( char *syntax, struct object *args )
{
   struct object *car;
   static int proto[] = { 1, ATOM_STRING };

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

   car = STACK_POP( stack );

   if ( chdir( car->data.atom->data.string->string ))
   {
      STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      return 0;
   }

   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_boundp( char *syntax, struct object *args )
{
   struct object *car;
   static int proto[] = { 1, ATOM_ATOM };

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

   car = STACK_POP( stack );

   if ( lookup_local( car->data.atom->id ) == NULL &&
        lookup_binding( car->data.atom ) == 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 )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 ].ptr )
            break;

      STACK_PUSH( stack, make_atom_from_number( i ))
   }

   return 0;
}

int do_buffers( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 ].ptr != NULL )
         {
            *ptr = make_atom_from_number( i );
            ptr = &( *ptr )->next;
         }
   }

   return 0;
}

int do_switch( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      struct object *car;
      int i;

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

      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 ].ptr == NULL )
      {
         fprintf( stderr, "%s: buffer %d is not open.\n", syntax, i );
         return 1;
      }

      buffer = ( DB *)buffer_stack->values[ i ].ptr;
      bookmarks = ( struct hash_elt **)bookmark_stack->values[ i ].ptr;

      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_version( char *syntax, struct object *args )
{
   struct object *result;
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 ];
   int len;
   static int proto[] = { 0 };

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

   len = snprintf( name, sizeof( name ), "<GENSYM#%d>", gensym_counter++ );
   STACK_PUSH( stack, make_atom_from_symbol( name, len ))

   return 0;
}

int do_libdir( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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;
   long int arg2, arg3;
   static int proto[] = { 3, ATOM_STRING, ATOM_FIXNUM, ATOM_FIXNUM };

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

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

   arg2 = car2->data.number;
   arg3 = car3->data.number;

   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;
   long int offset = 0, i, len, arg1;
   struct string *s;
   static int proto[] = { 2, ATOM_FIXNUM, ATOM_STRING };

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

   car2 = STACK_POP( stack );
   car1 = STACK_POP( stack );

   arg1 = car1->data.number;

   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;
   static int proto[] = { 0 };

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

   if ( interactive )
   {
      char *err = "already running interactively";
      STACK_PUSH( stack, make_atom_from_string( err, strlen( err )))
      return 0;
   }

   interactive = 1;
   i = stack->used;

   STACK_PUSH( open_envs, local_env )
   local_env = NULL;

   for( ; ; )
   {
      int depth, result;

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

      if ( stack->used == i )
         continue;

      if ( numberp( (( struct object *)stack->top->ptr )->flags ) == 0 &&
           islist( (( struct object *)stack->top->ptr )->flags ) == 0 &&
           (( struct object *)stack->top->ptr )->data.atom->id == underscore_id )
         break;

      result = evaluate();
      close_descriptors();

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

      stop = next_iteration = 0;
      STACK_POP( stack );
   }

   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 )
{
   static int proto[] = { 0 } ;

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

   STACK_PUSH( stack, make_atom_from_string( *arg_ptr, strlen( *arg_ptr )))

   return 0;
}

int do_next( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 *p, d[ MAXPATHLEN + 1 ];
   static int proto[] = { 0 } ;

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

   if (( p = getcwd( d, sizeof( 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;
   static int proto[] = { 1, ATOM_FIXNUM };

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

   car = STACK_POP( stack );
   exit( car->data.number );

   return 1;
}

struct object *make_atom_from_table( struct hash_elt **hash )
{
   struct object *object;
   struct atom *entry;
   char buffer[ 64 ];
   unsigned int len;

   len = snprintf( buffer, sizeof( buffer ), "<TABLE#%d>", table_counter++ );

   entry = get_id( buffer, len, 1 );
   entry->flags = ATOM_TABLE;

   entry->data.table = ( struct table *)memory( sizeof( struct table ));
   entry->data.table->hash = hash;
   entry->data.table->size = HASH_SIZE;
   entry->data.table->items = 0;
   entry->data.table->resize = HASH_SIZE * HASH_RESIZE;

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

   return object;
}

int do_table( char *syntax, struct object *args )
{
   struct hash_elt **hash;
   static int proto[] = { 0 };

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

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

   STACK_PUSH( stack, make_atom_from_table( hash ))

   return 0;
}

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

   /*
    * Detect overflow.
    */

   if ( table->size * HASH_RESIZE > ULONG_MAX )
      return;

   size = table->size * HASH_RESIZE;

#ifdef DEBUG
   fprintf( stderr, "[resizing table: items: %ld, old size: %ld...", table->items, table->size );
#endif

   new = memory( size * sizeof( struct hash_elt * ));
   bzero( new, size * sizeof( struct hash_elt * ));

   old = table->hash;
   old_size = table->size;

   table->hash = new;
   table->size = size;
   table->resize = size * HASH_RESIZE;

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

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

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

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

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

   free( old );

#ifdef DEBUG
   fprintf( stderr, "new size: %ld]\n", table->size );
#endif
}

int do_hash( char *syntax, struct object *args )
{
   struct object *car1, *car2, *car3, *key;
   static int proto[] = { 3, ATOM_TABLE, ATOM_ATOM, -1 };
   int found;

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

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

   if ( ! numberp( car2->flags ))
      key = car2;
   else
   {
      char buffer[ 64 ];
      int len;

      len = snprintf( buffer, sizeof( buffer ), "%ld", car2->data.number );

      key = make_object();
      key->data.atom = get_id( buffer, len, 1 );
      key->data.atom->flags = ATOM_FIXNUM ;
      key->data.atom->data.number = car2->data.number;
   }

   found = insert_elt( car1->data.atom->data.table->hash,
                       key->data.atom,
                       car3,
                       car1->data.atom->data.table->size );

   if ( ! found  && ++car1->data.atom->data.table->items > car1->data.atom->data.table->resize )
      resize_table( car1->data.atom->data.table );

   STACK_PUSH( stack, car3 )

   return 0;
}

int do_unhash( char *syntax, struct object *args )
{
   struct object *car1, *car2, *key;
   int found;
   static int proto[] = { 2, ATOM_TABLE, ATOM_ATOM };

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

   car2 = STACK_POP( stack );
   car1 = STACK_POP( stack );

   if ( ! numberp( car2->flags ))
      key = car2;
   else
   {
      char buffer[ 64 ];
      int len;

      len = snprintf( buffer, sizeof( buffer ), "%ld", car2->data.number );

      key = make_object();
      key->data.atom = get_id( buffer, len, 1 );
      key->data.atom->flags = ATOM_FIXNUM ;
      key->data.atom->data.number = car2->data.number;
   }

   found = remove_elt( car1->data.atom->data.table->hash,
                       key->data.atom,
                       car1->data.atom->data.table->size );

   STACK_PUSH( stack, car2 )

   if ( found )
      --car1->data.atom->data.table->items;

   return 0;
}

int do_lookup( char *syntax, struct object *args )
{
   struct object *car1, *car2, *key;
   static int proto[] = { 2, ATOM_TABLE, ATOM_ATOM };

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

   car2 = STACK_POP( stack );
   car1 = STACK_POP( stack );

   if ( ! numberp( car2->flags ))
      key = car2;
   else
   {
      char buffer[ 64 ];
      int len;

      len = snprintf( buffer, sizeof( buffer ), "%li", car2->data.number );

      key = make_object();
      key->data.atom = get_id( buffer, len, 1 );
      key->data.atom->flags = ATOM_FIXNUM ;
      key->data.atom->data.number = car2->data.number;

   }

   car1 = lookup_elt( car1->data.atom->data.table->hash,
                      key->data.atom,
                      car1->data.atom->data.table->size );

   if ( car1 != NULL )
      STACK_PUSH( stack, car1 )
   else
   {
      STACK_PUSH( stack, make_object())
      setlist( ( *( struct object **)stack->top )->flags );
   }

   return 0;
}

int do_keys( char *syntax, struct object *args )
{
   struct object *car, **ptr, *result;
   struct hash_elt **hptr, *hptr2;
   int i;
   static int proto[] = { 1, ATOM_TABLE };

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

   car = STACK_POP( stack );

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

   ptr = &result->data.head;

   if ( car->data.atom->data.table->items == 0 )
      result->data.head = NULL;
   else
   {
      hptr = car->data.atom->data.table->hash;

      for( i = 0; i < car->data.atom->data.table->size; ++i, ++hptr )
      {
         if ( *hptr == NULL )
            continue;

         for( hptr2 = *hptr; hptr2 != NULL; hptr2 = hptr2->next )
         {
            *ptr = make_object();

            if ( type( hptr2->key->flags ) == ATOM_FIXNUM )
            {
               setnumber(( *ptr )->flags );
               ( *ptr )->data.number = hptr2->key->data.number;
            }
            else
               ( *ptr )->data.atom = hptr2->key;

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

      *ptr = NULL;
   }

   return 0;
}

int do_values( char *syntax, struct object *args )
{
   struct object *car, **ptr, *result;
   struct hash_elt **hptr, *hptr2;
   int i;
   static int proto[] = { 1, ATOM_TABLE };

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

   car = STACK_POP( stack );

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

   ptr = &result->data.head;

   if ( car->data.atom->data.table->items == 0 )
      result->data.head = NULL;
   else
   {
      hptr = car->data.atom->data.table->hash;

      for( i = 0; i < car->data.atom->data.table->size; ++i, ++hptr )
      {
         if ( *hptr == NULL )
            continue;

         for( hptr2 = *hptr; hptr2 != NULL; hptr2 = hptr2->next )
         {
            *ptr = make_object();

            if ( numberp((( struct object *)hptr2->element.ptr )->flags ))
            {
               setnumber(( *ptr )->flags );
               ( *ptr )->data.number = (( struct object *)hptr2->element.ptr )->data.number;
            }
            else
               ( *ptr )->data.atom = (( struct object *)hptr2->element.ptr )->data.atom;

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

      *ptr = NULL;
   }

   return 0;
}

int do_redirect( char *syntax, struct object *args )
{
   void *ptr;
   struct object *car1, *car2, *car3, *car4;
   long 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, ATOM_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, ATOM_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, ATOM_STRING );
      return 1;
   }

   car1 = STACK_POP( stack );

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

   arg1 = car1->data.number;

   if ( arg1 < 0 || arg1 > 2 )
   {
      fprintf( stderr, "%s: descriptor %ld out of range.\n", syntax, arg1 );
      return 1;
   }

   flags = 0;

   if ( arg1 )
   {
      fflush( ( arg1 == 1 ? stdout : stderr ));
      flags = O_CREAT;

      if ( car3 != NULL && car3->data.number )
         flags = O_APPEND;
   }

   flags |= ( arg1 ? ( O_WRONLY | O_NONBLOCK ) :
                     ( O_RDONLY | O_NONBLOCK ));

   if ( car4 != NULL && car4->data.number )
      flags |= ( arg1 ? O_EXLOCK : O_SHLOCK );

   if (( ptr = setmode( "0600" )) == NULL )
   {
      fprintf( stderr, "%s: setmode(): %s.\n", syntax, strerror( errno ));
      return 1;
   }

   mode = getmode( ptr, 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 ), strlen( strerror( errno ))))
      }

      return 0;
   }

   if ( arg1 && ( car3 == NULL || car3->data.number == 0 ))
      if ( ftruncate( fd, 0 ))
      {
         close( fd );
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
         return 0;
      }

   if (( flags = dup( arg1 )) < 0 )
   {
      close( fd );
      fprintf( stderr, "%s: dup: %s.\n", syntax, strerror( errno ));
      return 1;
   }

   fcntl( flags, F_SETFD, FD_CLOEXEC );

   if ( arg1 )
      fclose( (( arg1 == 1 ? stdout : stderr )));

   STACK_PUSH_INT( descriptors[ arg1 ], 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 && car3->data.number ? "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 = STACK_POP_INT( 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 )
{
   long int arg1;
   struct object *car;
   static int proto[] = { 1, ATOM_FIXNUM };

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

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

   if ( arg1 < 0 || arg1 > 2 )
   {
      fprintf( stderr, "%s: descriptor argument %ld 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;
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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;
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 ), strlen( strerror( errno ))))
      return 0;
   }

   readdir( dir );
   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;
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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;
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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;
   static int proto[] = { 1, ATOM_STRING };

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

   car = STACK_POP( stack );

   if ( unlink( car->data.atom->data.string->string ))
   {
      STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      return 0;
   }

   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_rmdir( char *syntax, struct object *args )
{
   struct object *car;
   static int proto[] = { 1, ATOM_STRING };

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

   car = STACK_POP( stack );

   if ( rmdir( car->data.atom->data.string->string ))
   {
      STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      return 0;
   }

   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_rename( char *syntax, struct object *args )
{
   struct object *car1, *car2;
   static int proto[] = { 2, ATOM_STRING, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 ), strlen( strerror( errno ))))
      return 0;
   }

   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_words( char *syntax, struct object *args )
{
   long int i, last, result, flag, total;
   static int proto[] = { 0 };

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

   if ( check_args( syntax, args, proto ))
      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 )
      {
         if ( i == 1 )
         {
            STACK_PUSH( stack, make_atom_from_number( 0 ))
            return 0;
         }

         fprintf( stderr, "%s: db->get: key does not exist: %ld.\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;
   static int proto[] = { 0 };

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

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

   STACK_PUSH( stack, make_atom_from_number( t ))

   return 0;
}

int do_random( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      struct object *obj;
      int r;

      obj = STACK_POP( stack );

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

      r = arc4random_uniform( obj->data.number );
      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, ATOM_FIXNUM );
         return 1;
      }

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

         really = car2->data.number;
      }

      gmt = car1->data.number;
   }

   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 *car1, *car2, *car3;
   time_t t;
   struct tm *lt;
   int len, gmt = 0, really = 0;
   long int i;
   char buffer[ 128 ];

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

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

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

         car3 = STACK_POP( stack );

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

         really = car3->data.number;

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

      car2 = STACK_POP( stack );

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

      gmt = car2->data.number;
   }

   car1 = STACK_POP( stack );

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

   i = car1->data.number;
   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;
   }

   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_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, ATOM_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 )
{
   static int proto[] = { 0 };

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

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

   return 1;
}

int do_block( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

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

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

   blocked = 1;
   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_unblock( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

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

   signal( SIGHUP, SIG_DFL );
   signal( SIGINT, SIG_DFL );
   signal( SIGQUIT, 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;
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 0 };

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

   kill( 0, SIGSTOP );
   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_beep( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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;
   long int i;
   static int proto[] = { 1, -1 };

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

   car = STACK_POP( stack );

   i = 0;

   if ( islist( car->flags ))
   {
      for( item = car->data.head; item != NULL; item = item->next )
         ++i;
   }
   else
   {
      long int t;

      t = ( numberp( car->flags ) ? 0 : type( car->data.atom->flags ));

      if ( t == ATOM_STRING )
         i = car->data.atom->data.string->length;
      else if ( t == ATOM_STACK )
         i = car->data.atom->data.stack->used;
      else if ( t == ATOM_RECORD )
         i = car->data.atom->data.record->integer;
      else if ( t == ATOM_TABLE )
         i = car->data.atom->data.table->items;
      else
      {
         fprintf( stderr, "%s: argument 1 did not evaluate to a string, "
                  " a table, 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 )
{
   static int proto[] = { 2, ATOM_STRING, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 0 };

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

   fatal = 1;
   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_nofatal( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 == 1000000 )
      return 0;

   tv.tv_sec = 0;
   tv.tv_nsec = 10000;

   nanosleep( &tv, NULL );

   return 1;
}

int do_sqlp( char *syntax, struct object *args )
{
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 );
         return 0;
      }

      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 )
{
   static int proto[] = { 1, ATOM_DB };

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

   {
      struct object *car;

      car = STACK_POP( stack );

      if ( car->data.atom->data.db == NULL )
      {
         STACK_PUSH( stack, make_atom_from_number( 0 ))
         return 0;
      }

      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;
   long 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 )
   {
      if ( *ptr == NULL )
         *list_ptr = make_atom_from_string( "", 0 );
      else
         *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 )
{
   static int proto[] = { 2, ATOM_DB, ATOM_STRING };

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

   {
      struct object *sql, *db;
      char *sql_err;

      sql = STACK_POP( stack );
      db = STACK_POP( stack );

      if ( db->data.atom->data.db == NULL )
      {
         char * err = "database has been closed";
         STACK_PUSH( stack, make_atom_from_string( err, strlen( err )))
         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[ 64 ];
   int len;

   len = snprintf( buffer, sizeof( buffer ), "<SQL#%d>", sql_counter++ );
   entry = get_id( buffer, len, 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 )
{
   static int proto[] = { 2, ATOM_DB, ATOM_STRING };

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

   {
      sqlite3_stmt *compiled;
      const char *ignored;
      struct object *arg1, *arg2;

      arg2 = STACK_POP( stack );
      arg1 = STACK_POP( stack );

      if ( sqlite3_prepare_v2( arg1->data.atom->data.db,
                               arg2->data.atom->data.string->string,
                               arg2->data.atom->data.string->length,
                               &compiled,
                               &ignored ) != SQLITE_OK )
      {
         const char *err = sqlite3_errmsg( arg1->data.atom->data.db );
         STACK_PUSH( stack, make_atom_from_string(( char *)err, strlen( err )))
         return 0;
      }

      STACK_PUSH( stack, make_atom_from_prepared_sql( compiled ))
   }

   return 0;
}

int do_sqlite_bind( char *syntax, struct object *args )
{
   static int proto[] = { 3, ATOM_SQL, ATOM_FIXNUM, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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,
                              arg2->data.number,
                              arg3->data.atom->data.string->string,
                              arg3->data.atom->data.string->length,
                              SQLITE_TRANSIENT ) != SQLITE_OK )
      {
         const char *err = sqlite3_errmsg( sqlite3_db_handle( arg1->data.atom->data.sql ));
         STACK_PUSH( stack, make_atom_from_string(( char *)err, strlen( err )))
         return 0;
      }

      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_sqlite_step( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_SQL };

   if ( check_args( syntax, args, proto ))
      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
         {
            const char *err = sqlite3_errmsg( sqlite3_db_handle( arg->data.atom->data.sql ));
            STACK_PUSH( stack, make_atom_from_string(( char *)err, strlen( err )))
         }

         return 0;
      }

      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_sqlite_row( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_SQL };

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

   {
      struct object *arg1, *result, **ptr;
      int total, i, len;
      const unsigned 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 )
      {
         if ( !( len = sqlite3_column_bytes( arg1->data.atom->data.sql, i )))
            column = ( const unsigned char *)"";
         else if (( column = sqlite3_column_text( arg1->data.atom->data.sql, i )) == NULL )
         {
            const char *err = sqlite3_errmsg( sqlite3_db_handle( arg1->data.atom->data.sql ));
            STACK_PUSH( stack, make_atom_from_string(( char *)err, strlen( err )))
            return 1;
         }

         *ptr = make_atom_from_string( ( char *)column, len );
      }
   }

   return 0;
}

int do_sqlite_finalize( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_SQL };

   if ( check_args( syntax, args, proto ))
      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 )
      {
         const char *err = sqlite3_errmsg( sqlite3_db_handle( arg1->data.atom->data.sql ));
         STACK_PUSH( stack, make_atom_from_string(( char *)err, strlen( err )))
         return 0;
      }

      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 )
{
   static int proto[] = { 1, ATOM_SQL };

   if ( check_args( syntax, args, proto ))
      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 )
      {
         const char *err = sqlite3_errmsg( sqlite3_db_handle( arg1->data.atom->data.sql ));
         STACK_PUSH( stack, make_atom_from_string(( char *)err, strlen( err )))
         return 0;
      }

      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;
   long 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, ATOM_FIXNUM );
         return 1;
      }

      i = result->data.number;
      result = NULL;

      if ( i < 0 )
      {
         fprintf( stderr, "%s: initial size < 0: %ld.\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 )
{
   static int proto[] = { 1, ATOM_STACK };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 2, ATOM_STACK, -1 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 2, ATOM_STACK, -1 };

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

   {
      long 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 ].ptr = car2;
      }
      else
         STACK_PUSH( car1->data.atom->data.stack, car2 )

      STACK_PUSH( stack, car2 )
   }

   return 0;
}

int do_shift( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_STACK };

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

   {
      long 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 ].ptr;

         for( i = 0; i < car->data.atom->data.stack->used - 1; ++i )
            car->data.atom->data.stack->values[ i ].ptr =
               car->data.atom->data.stack->values[ i + 1 ].ptr;

         STACK_POP( car->data.atom->data.stack );
      }

      STACK_PUSH( stack, result )
   }

   return 0;
}

int do_index( char *syntax, struct object *args )
{
   static int proto[] = { 2, ATOM_STACK, ATOM_FIXNUM };

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

   {
      struct object *car1, *car2;
      struct stack *stk;
      long int i;

      car2 = STACK_POP( stack );
      i = car2->data.number;

      car1 = STACK_POP( stack );
      stk = car1->data.atom->data.stack;

      if ( i < 0 )
      {
         fprintf( stderr, "%s: index < 0: %ld.\n", syntax, i );
         return 1;
      }
      else if ( i >= stk->used )
      {
         fprintf( stderr, "%s: index %ld out of range.\n", syntax, i );
         return 1;
      }

      STACK_PUSH( stack, stk->values[ i ].ptr )
   }

   return 0;
}

int do_store( char *syntax, struct object *args )
{
   static int proto[] = { 3, ATOM_STACK, ATOM_FIXNUM, -1 };

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

   {
      struct object *car1, *car2, *car3;
      struct stack *stk;
      long int i;

      car3 = STACK_POP( stack );

      car2 = STACK_POP( stack );
      i = car2->data.number;

      car1 = STACK_POP( stack );
      stk = car1->data.atom->data.stack;

      if ( i < 0 || i >= stk->used )
      {
         fprintf( stderr, "%s: index %ld out of range.\n", syntax, i );
         return 1;
      }

      STACK_PUSH( stack,  stk->values[ i ].ptr = car3 )
   }

   return 0;
}

int do_topidx( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_STACK };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, -1 };

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

   {
      struct object *obj, *result;
      int t;

      obj = STACK_POP( stack );

      if ( numberp( obj->flags ) ||
           (( t = type( obj->data.atom->flags )) != ATOM_CLOSURE &&
              t != ATOM_MACRO ))
      {
         char *err = "argument 1 did not a evaluate to a closure or a maco closure";
         STACK_PUSH( stack, make_atom_from_string( err, strlen( err )))
         return 0;
      }

      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, ATOM_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, ATOM_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, ATOM_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", 3 );

         ( *ptr2 )->data.head->next = make_object();
         setlist( ( *ptr2 )->data.head->next->flags );

         ( *ptr2 )->data.head->next->data.head =
            make_atom_from_symbol( "quote", 5 );

         ( *ptr2 )->data.head->next->data.head->next =
            make_atom_from_symbol( ptr3->data.atom->syntax, ptr3->data.atom->len );

         ( *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", 6 );
      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: evaluation of body expression %d failed.\n", syntax, i );
            return 1;
         }
         else
            return 0;
      }

      STACK_PUSH( stack, result )
   }

   return 0;
}

int do_transfer( char *syntax, struct object *args )
{
   static int proto[] = { 5, ATOM_FIXNUM, ATOM_FIXNUM, ATOM_FIXNUM,
                          ATOM_FIXNUM, ATOM_FIXNUM };

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

   if ( buffer_stack->used == 0 )
   {
      fprintf( stderr, "%s: no buffers have been opened.\n", syntax );
      return 1;
   }

   {
      struct object *obj;
      long int bn[ 2 ], f1, t1, t2, j, i, inc, after_line, amount;
      DB *bp[ 2 ];

      obj = STACK_POP( stack );
      t2 = obj->data.number;

      obj = STACK_POP( stack );
      bn[ 1 ] = obj->data.number;

      obj = STACK_POP( stack );
      t1 = obj->data.number;

      obj = STACK_POP( stack );
      f1 = obj->data.number;

      obj = STACK_POP( stack );
      bn[ 0 ] = obj->data.number;

      for( j = 0; j < 2; ++j )
      {
         for( i = 0; i < buffer_stack->used; ++i )
         {
            if ( buffer_stack->values[ i ].ptr != NULL )
            {
               if ( i == bn[ j ] )
                  goto CONT;
            }
         }

         fprintf( stderr, "%s: buffer %ld is not open.\n", syntax, bn[ j ] );
         return 1;

      CONT:
         bp[ j ] = buffer_stack->values[ i ].ptr;
      }

      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 %ld is empty.\n", syntax, bn[ 0 ] );
         return 1;
      }

      if ( f1 < 1 || f1 > *( int *)dbt_key.data )
      {
         fprintf( stderr, "%s: argument 2 out of range: %ld.\n", syntax, f1 );
         return 1;
      }

      if ( t1 < 1 || t1 > *( int *)dbt_key.data )
      {
         fprintf( stderr, "%s: argument 3 out of range: %ld.\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 %ld is empty.\n", syntax, bn[ 1 ] );
         return 1;
      }

      if ( t2 < 0 || t2 > *( int *)dbt_key.data )
      {
         fprintf( stderr, "%s: argument 5 out of range: %ld.\n", syntax, f1 );
         return 1;
      }

      inc = ( f1 < t1 ? 1 : -1 );
      after_line = t2;
      amount = 1 + abs( f1 - t1 );

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

      adjust_bookmarks( after_line, amount, bn[ 1 ] );

      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;

      /*
       * On OS X fd[ 1 ] is always the writeable end, unlike FreeBS, where
       * pipes are bidirectional.  Under FreeBSD, we always give fd[ 1 ] to the
       * child, and fd[ 0 ] to the parent, but under OS X we must give each
       * process the descriptor which applies to that processes role as reader
       * or writer.
       */

      case 0:
         if (( dup2( fd[ !wrt  ], !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[ !( wrt && 1 ) ] );

         if ( std )
         {
            if (( flag = dup( wrt )) < 0 )
            {
               close( fd[ 0 ] );
               fprintf( stderr, "%s: dup: %s.\n", syntax, strerror( errno ));
               return -1;
            }

            fcntl( flag, F_SETFD, FD_CLOEXEC );
            STACK_PUSH_INT( descriptors[ wrt ], flag )

            if ( wrt )
               fclose(( wrt == 1 ? stdout : stderr ));

            if ( dup2( fd[ ( wrt && 1 ) ], wrt ) < 0 )
            {
               close( fd[ ( wrt && 1 ) ] );
               close( STACK_POP_INT( descriptors[ wrt ] ));
               fprintf( stderr, "%s: dup2: %s.\n", syntax, strerror( errno ));
               return -1;
            }

            close( fd[ ( wrt && 1 ) ] );

            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[ ( wrt && 1 ) ] );
}

int do_pipe( char *syntax, struct object *args )
{
   static int proto[] = { 2, ATOM_FIXNUM, ATOM_STRING };

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

   {
      int arg1, pid;
      struct object *car1, *car2;

      car1 = STACK_POP( stack );
      car2 = STACK_POP( stack );
      arg1 = car2->data.number;

      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 )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 2, ATOM_STRING, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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?  No, you're not.
       */

      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 ), strlen( strerror( errno  ))))
      return -1;
   }

   switch(( pid = fork() ))
   {
      case -1:
         close( fd[ 0 ] );
         close( fd[ 1 ] );
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
         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 ))

   fcntl( fd[ 0 ], F_SETFD, FD_CLOEXEC );

   return fd[ 0 ];
}

int open_unix( char *path )
{
   int fd;
   char buffer[ 64 ];
   struct sockaddr_un sa;

   if (( fd = socket( PF_LOCAL, SOCK_STREAM, 0 )) < 0 )
   {
      int len;

      len = snprintf( buffer, sizeof( buffer ), "socket(): %s", strerror( errno ));
      STACK_PUSH( stack, make_atom_from_string( buffer, len ))
      return -1;
   }

   bzero( &sa, sizeof( struct sockaddr_un ));
   sa.sun_family = PF_LOCAL;
   strncpy( sa.sun_path, path, sizeof( sa.sun_path ) - 1 );

   if ( connect( fd, ( struct sockaddr *)&sa, SUN_LEN( &sa )) < 0 )
   {
      int len;

      close( fd );
      len = snprintf( buffer, sizeof( buffer ), "connect(): %s", strerror( errno ));
      STACK_PUSH( stack, make_atom_from_string( buffer, len ))
      return -1;
   }

   child_pid = -3;
   STACK_PUSH( stack, make_atom_from_number( 1 ))

   fcntl( fd, F_SETFD, FD_CLOEXEC );

   return fd;
}

int open_remote( char *name, int port, char *service )
{
   int fd = -1, result;
   char buffer[ 255 ];
   struct addrinfo hints, *res, *ptr;

   if ( port > 0 )
      snprintf( buffer, sizeof( buffer ), "%d", port );
   else if ( port == 0 )
      return open_unix( name );
   else
      port = 0;

   bzero( &hints, sizeof( struct addrinfo ));
   hints.ai_family = PF_UNSPEC;
   hints.ai_socktype = SOCK_STREAM;

   if (( result = getaddrinfo( name, ( port ? buffer : service ), &hints, &res )))
   {
      STACK_PUSH( stack, make_atom_from_string( ( char *)gai_strerror( result ), strlen( gai_strerror( result ))))
      return -1;
   }

   for( ptr = res; ptr != NULL; ptr = ptr->ai_next )
   {
      fd = socket( ptr->ai_family, ptr->ai_socktype, ptr->ai_protocol );

      if ( fd == -1 )
         continue;

      if ( connect( fd, ptr->ai_addr, ptr->ai_addrlen ) == -1 )
      {
         close( fd );
         fd = -1;
         continue;
      }

      break;
   }

   if ( res != NULL )
      freeaddrinfo( res );

   if ( fd == -1 )
   {
      STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      return -1;
   }

   child_pid = -2;
   STACK_PUSH( stack, make_atom_from_number( 1 ))

   fcntl( fd, F_SETFD, FD_CLOEXEC );

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

   {
      int num = 0;
      struct object *name, *port = NULL;

      if ( remote )
      {
         port = STACK_POP( stack );

         if ( islist( port->flags ) ||
              (( num = numberp( port->flags )) == 0 &&
                 type( port->data.atom->flags ) != ATOM_STRING ))
         {
            fprintf( stderr, "%s: port argument is not a string nor 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, ATOM_STRING );
         return 1;
      }

      if ( remote )
         child_fd = open_remote( name->data.atom->data.string->string,
                                 ( num ? port->data.number : -1 ),
                                 ( num ? NULL : port->data.atom->data.string->string ));
      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 )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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, ATOM_STRING );
         return 1;
      }
   }

   {
      char *ptr, *current;
      int j, len, written;

      j = i - 1;

      while( --i )
      {
         ptr = (( struct object *)stack->values[ stack->used - i ].ptr )->data.atom->data.string->string;
         len = (( struct object *)stack->values[ stack->used - i ].ptr )->data.atom->data.string->length;

         current = ptr;
         written = 0;

         do
         {
            current += written;
            len -= written;

            if (( written = write( child_fd, current, len )) < 0 )
            {
               char buffer[ 128 ];
               int length;

               length = snprintf( buffer, sizeof( buffer ), "%s: write: %s.\n", syntax, strerror( errno ));
               STACK_PUSH( stack, make_atom_from_string( buffer, length ))
               return 0;
            }
         }
         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 )
{
   static int proto[] = { 0 };

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

   if ( child_fd != -1 )
   {
      if ( child_eof )
         child_eof = 0;

      close( child_fd );
      child_fd = -1;
   }

   if ( child_pid < -1 )
      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 )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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, ATOM_CLOSURE );
         return 1;
      }

      closure = current_closure;
   }
   else if ( type( car->data.atom->flags ) != ATOM_CLOSURE )
   {
      print_err( ERR_ARG_TYPE, syntax, 1, ATOM_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 )
{
   static int proto[] = { 1, ATOM_STRING };

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

   {
      struct stat st;
      struct group *gp;
      struct passwd *pw;
      struct object *obj, *result;

      obj = STACK_POP( stack );

   AGAIN:
      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;
         }

         if ( errno == EINTR )
            goto AGAIN;

         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
         return 0;
      }

      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 )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 ), strlen( strerror( errno ))))
         return 0;
      }

      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_access( char *syntax, struct object *args )
{
   static int proto[] = { 2, ATOM_STRING, ATOM_FIXNUM };

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

   {
      int mode;
      struct object *obj1, *obj2;

      obj2 = STACK_POP( stack );
      obj1 = STACK_POP( stack );
      mode = obj2->data.number;

      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 = eaccess( 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 number )
{
   int i;
   struct hash_elt **ptr, *ptr2;

   if ( buffer == NULL )
      return;

   ptr = ( number < 0 ? bookmarks : ( struct hash_elt **)bookmark_stack->values[ number ].ptr );

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

      for( ptr2 = *ptr; ptr2 != NULL; ptr2 = ptr2->next )
         if ( ptr2->element.integer > start )
            ptr2->element.integer += quantity;
   }
}

void delete_bookmarks( int start, int end )
{
   int i;
   struct hash_elt **ptr, *ptr2;

   if ( buffer == NULL )
      return;

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

      for( ptr2 = *ptr; ptr2 != NULL; ptr2 = ptr2->next )
         if ( ptr2->element.integer >= start && ptr2->element.integer <= end )
            ptr2->element.integer = -1;
   }
}

int do_setmark( char *syntax, struct object *args )
{
   static int proto[] = { 2, ATOM_ATOM, ATOM_FIXNUM };

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

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

   {
      struct object *car1, *car2, *key;
      int line, last;

      car2 = STACK_POP( stack );
      car1 = STACK_POP( stack );

      line = car2->data.number;

      if ( do_lastline( syntax, NULL ))
         return 1;

      last = (( struct object * )stack->top->ptr )->data.number;
      STACK_POP( stack );

      if ( line < 0 || line > last )
      {
         fprintf( stderr, "%s: line %ld out of range.\n", syntax,
                  car2->data.number );
         return 1;
      }

      if ( numberp( car1->flags ) )
      {
         char buffer[ 64 ];
         int len;

         len = snprintf( buffer, sizeof( buffer ), "%li", car1->data.number );

         key = make_object();
         key->data.atom = get_id( buffer, len, 1 );
         key->data.atom->flags = ATOM_FIXNUM ;
         key->data.atom->data.number = car1->data.number;
      }
      else
         key = car1;

      insert_elt_int( bookmarks, key->data.atom, line );
   }

   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_getmark( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_ATOM };

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

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

   {
      struct object *car, *key;
      int line;

      car = STACK_POP( stack );

      if ( numberp( car->flags ))
      {
         char buffer[ 64 ];
         int len;

         len = snprintf( buffer, sizeof( buffer ), "%li", car->data.number );

         key = make_object();
         key->data.atom = get_id( buffer, len, 1 );
         key->data.atom->flags = ATOM_FIXNUM ;
         key->data.atom->data.number = car->data.number;
      }
      else
         key = car;

      line = lookup_elt_int( bookmarks, key->data.atom );
      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;

   sigwinch = 1;
}

int do_boldface( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   putp( bd );
   fflush( stdout );

   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_normal( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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;
   static int proto[] = { 1, ATOM_FIXNUM };

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

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

   timeval.tv_sec = 0;
   timeval.tv_usec = arg1;

   was_canon = tty_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;
   static int proto[] = { 3, ATOM_FIXNUM, ATOM_FIXNUM, ATOM_FIXNUM };

   if ( cl == ( char *)-1 || ce == ( char *)-1 || cm == ( char *)-1 )
   {
      fprintf( stderr, "%s: terminal has insufficient capabilities.\n",
               syntax );
      return 1;
   }

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

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

   if ( buffer == NULL )
   {
      fprintf( stderr, "%s: no buffer is open.\n", syntax );
      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 ));
      return 1;
   }

   last = *( int *)dbt_key.data;

   key = car1->data.number;

   if ( key < 0 || key > last )
   {
      fprintf( stderr, "%s: line %d out of range.\n", syntax, key );
      return 1;
   }

   start = car2->data.number;

   if ( start < 0 )
   {
      fprintf( stderr, "%s: column %d out of range.\n", syntax, start );
      return 1;
   }

   tabstop = car3->data.number;

   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 )
{
   static int proto[] = { 0 };

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

   if ( sf == ( char *)-1 || sc == ( char *)-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 )
{
   static int proto[] = { 0 };

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

   if ( sr == ( char *)-1 || sc == ( char *)-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 )
{
   static int proto[] = { 0 };

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

   if ( cl != ( char *)-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;
   static int proto[] = { 2, ATOM_FIXNUM, ATOM_FIXNUM };

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

   car2 = STACK_POP( stack );
   car1 = STACK_POP( stack );

   y = car1->data.number;
   x = car2->data.number;

   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;
   static int proto[] = { 2, ATOM_FIXNUM, ATOM_FIXNUM };

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

   car2 = STACK_POP( stack );
   car1 = STACK_POP( stack );

   if ( car1->data.number < 0 ||
        car1->data.number > LINES - 1 )
   {
      fprintf( stderr, "%s: line %ld out of range.\n", syntax,
               car1->data.number );
      return 1;
   }

   if ( car2->data.number < 0 ||
        car2->data.number > COLS - 1 )
   {
      fprintf( stderr, "%s: column %ld out of range.\n", syntax,
               car2->data.number );
      return 1;
   }

   putp( tgoto( cm, car2->data.number, car1->data.number ));
   putp( ce );
   fflush( stdout );

   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_hide( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   putp( vi );
   fflush( stdout );

   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_show( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   putp( ve );
   fflush( stdout );

   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_insertln( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   if ( al == ( char *)-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, oe;
   static int proto[] = { 0 };

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

   if ( pushed_back >= 0 )
   {
      STACK_PUSH( stack, make_atom_from_number( pushed_back ))
      pushed_back = -1;
      return 0;
   }
     
   fflush( stdin );
   fflush( stdout );
   fflush( stderr );

   if (( was_canon = tty_mode ))
      nocanon( syntax );

AGAIN:
   set_sigwinch_intr();

   c = 0;
   result = read( 0, &c, 1 );

   oe = errno;
   signal( SIGWINCH, sigwinch_handler );
   errno = oe;

   if ( result == 0 )
      STACK_PUSH( stack, make_atom_from_number( -1 ))
   else if ( result < 0 )
   {
      switch( errno )
      {
         case EINTR:
            if ( !sigwinch )
               goto AGAIN;

            STACK_PUSH( stack, make_atom_from_number( -2 ))
            break;

         case EAGAIN:
            goto AGAIN;

         default:
            STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      }
   }
   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;
   static int proto[] = { 1, ATOM_FIXNUM };

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

   car = STACK_POP( stack );
   pushed_back = car->data.number;

   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_canon( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   canon( syntax );
   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_nocanon( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   nocanon( syntax );
   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_noprinter( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   printer = 0;
   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_printer( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   printer = 1;
   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_shexec( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 ), strlen( strerror( errno ))))
   }

   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, ATOM_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 ), strlen( strerror( errno ))))

   return 0;
}

int do_truncate( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      struct object *car1;

      car1 = STACK_POP( stack );

      if ( ftruncate( 1, car1->data.number ) < 0 )
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      else
         STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_symbolp( char *syntax, struct object *args )
{
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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, ATOM_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 );
      insert_binding( args->data.head->data.atom, value );

      if ( old != NULL )
         STACK_PUSH( stack, old )

      result = do_progn( syntax, args->next );

      if ( old != NULL )
         insert_binding( args->data.head->data.atom, old );
      else
         remove_binding( args->data.head->data.atom );

      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 )
{
   static int proto[] = { 2, ATOM_STRING, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 ), strlen( strerror( errno ))))
         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 ), strlen( strerror( errno ))))
         return 1;
      }

      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_chown( char *syntax, struct object *args )
{
   static int proto[] = { 3, ATOM_STRING, ATOM_STRING, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 )
         {
            char *err = "only root may change user";
            STACK_PUSH( stack, make_atom_from_string( err, strlen( err )))
            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 ), strlen( strerror( errno ))))
            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 ), strlen( strerror( errno ))))
         return 0;
      }

      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_clear( char *syntax, struct object *args )
{
   static int proto[] = { 2, ATOM_STACK, ATOM_FIXNUM };

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

   {
      struct object *car1, *car2;
      int n;

      car2 = STACK_POP( stack );
      car1 = STACK_POP( stack );

      n = car2->data.number;

      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 )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 2, ATOM_STRING, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 ), strlen( strerror( errno ))))
      else if ( setuid( passwd->pw_uid ) < 0 )
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      else
         STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_getuid( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 ), strlen( strerror( errno ))))
      else if ( seteuid( passwd->pw_uid ) < 0 )
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      else
         STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_seek( char *syntax, struct object *args )
{
   static int proto[] = { 3, ATOM_FIXNUM, ATOM_FIXNUM, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 = car1->data.number ) != 0 && fd != 2 && fd != 1 )
      {
         fprintf( stderr, "%s: descriptor argument out of range: %d.\n", syntax, fd );
         return 1;
      }

      offset = car2->data.number;
      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 ), strlen( strerror( errno ))))
            return 0;
         }
      }
      else
      {
         if (( offset = fseek( ( fd == 1 ? stdout : stderr ), offset, whence ))
             < 0 )
         {
            STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
            return 0;
         }
      }

      STACK_PUSH( stack, make_atom_from_number( offset ))
   }

   return 0;
}

struct object *make_atom_directly_from_string( char *s, unsigned long 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 )
{
   static int proto1[] = { 1, ATOM_FIXNUM };
   static int proto2[] = { 2, ATOM_FIXNUM, ATOM_FIXNUM };

   if ( args == NULL )
   {
      print_err( ERR_MISSING_ARGS, syntax, 1, 0 );
      return 1;
   }
   else if ( args->next == NULL )
   {
      if ( check_args( syntax, args, proto1 ))
         return 1;
   }
   else if ( args->next->next != NULL )
   {
      print_err( ERR_MORE_ARGS, syntax, 2, 0 );
      return 1;
   }
   else
   {
      if ( check_args( syntax, args, proto2 ))
         return 1;
   }

   {
      struct object *car;
      char *buffer, *ptr;
      int total, timeout, returned, oe;
      struct itimerval value;

      timeout = 0;

      if ( args->next != NULL )
      {
         car = STACK_POP( stack );
         timeout = car->data.number;
      }

      car = STACK_POP( stack );
      total = car->data.number;

      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;

         set_sigalrm_intr();
         setitimer( ITIMER_REAL, &value, NULL );
      }

      returned = read( 0, ptr, total );

      if ( timeout )
      {
         value.it_value.tv_sec = 0;
         value.it_value.tv_usec = 0;

         oe = errno;
         signal( SIGALRM, sigalrm_handler );
         setitimer( ITIMER_REAL, &value, NULL );
         errno = oe;
      }

      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( "", 0 ))
               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 )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 ), strlen( strerror( errno ))))
         return 0;
      }

      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_writelock( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 ), strlen( strerror( errno ))))
         return 0;
      }

      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_unlock( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      struct object *car;
      int result, fd;

      car = STACK_POP( stack );
      fd = car->data.number;

      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 ), strlen( strerror( errno ))))
         return 0;
      }

      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_hostname( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   {
      char hostname[ MAXHOSTNAMELEN + 1 ];

      if ( gethostname( hostname, MAXHOSTNAMELEN ) < 0 )
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      else
         STACK_PUSH( stack, make_atom_from_string( hostname, strlen( hostname )))
   }

   return 0;
}

int do_symlink( char *syntax, struct object *args )
{
   static int proto[] = { 2, ATOM_STRING, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 ), strlen( strerror( errno ))))
         return 0;
      }
   }

   STACK_PUSH( stack, make_atom_from_number( 1 ))
   return 0;
}

int do_gecos( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      struct object *car;
      union stack_u *ptr, *result;
      int size, i;

      car = STACK_POP( stack );
      size = car->data.number;

      if ( size < 1 )
      {
         fprintf( stderr, "%s: argument 1 is less than 1.\n", syntax );
         return 1;
      }

      result = ptr = memory(( size * sizeof( union stack_u )) + 1 );
      ptr->integer = size;

      for( i = 0; i < size; ++i )
         ( ++ptr )->ptr = make_empty_list();

      STACK_PUSH( stack, make_atom_from_record( result ))
   }

   return 0;
}

int do_getfield( char *syntax, struct object *args )
{
   static int proto[] = { 2, ATOM_RECORD, ATOM_FIXNUM };

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

   {
      struct object *car1, *car2;
      long int idx;

      car2 = STACK_POP( stack );
      car1 = STACK_POP( stack );

      idx = car2->data.number;

      if ( idx < 0 )
      {
         fprintf( stderr, "%s: index %ld is less than 0.\n", syntax, idx );
         return 1;
      }
      else if ( idx >= car1->data.atom->data.record[ 0 ].integer )
      {
         fprintf( stderr, "%s: index %ld beyond end of record.\n", syntax, idx );
         return 1;
      }

      STACK_PUSH( stack, car1->data.atom->data.record[ idx + 1 ].ptr )
   }

   return 0;
}

int do_setfield( char *syntax, struct object *args )
{
   static int proto[] = { 3, ATOM_RECORD, ATOM_FIXNUM, -1 };

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

   {
      struct object *car1, *car2, *car3;
      long int idx;

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

      idx = car2->data.number;

      if ( idx < 0 )
      {
         fprintf( stderr, "%s: index %ld is less than 0.\n", syntax, idx );
         return 1;
      }
      else if ( idx >= car1->data.atom->data.record[ 0 ].integer )
      {
         fprintf( stderr, "%s: index %ld beyond end of record.\n", syntax, idx );
         return 1;
      }

      car1->data.atom->data.record[ idx + 1 ].ptr = car3;

      STACK_PUSH( stack, car3 )
   }

   return 0;
}

int do_extend( char *syntax, struct object *args )
{
   static int proto[] = { 2, ATOM_SYMBOL, -1 };

   if ( local_env == NULL )
   {
      fprintf( stderr, "%s: no local environment is active.\n", syntax );
      return 1;
   }

   if ( check_args( syntax, args, proto ))
      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_INT( local_env->data.atom->data.act_record, car1->data.atom->id )

      STACK_PUSH( stack, car2 )
   }

   return 0;
}

int do_recordp( char *syntax, struct object *args )
{
   static int proto[] = { 1, -1 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   long 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 %ld 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 %ld 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 %ld 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 %ld 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, ATOM_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: evaluation of \"from\" value in argument 1 failed.\n", syntax );

      return 1;
   }

   STACK_PUSH( stack, to )

   if ( evaluate() )
   {
      if ( !stop )
         fprintf( stderr, "%s: evaluation of \"to\" value in argument 1 failed.\n", syntax );

      return 1;
   }

   if ( incr != NULL )
   {
      STACK_PUSH( stack, incr )

      if ( evaluate() )
      {
         if ( !stop )
            fprintf( stderr, "%s: evaluation of \"increment\" value in argument 1 failed.\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;
   }

   {
      long int start, end, inc, idx, old_stack;
      int failed;
      struct object *result = NULL, **act_ptr, *old_env;

      old_stack = stack->used;

      start = from->data.number;
      end = to->data.number;

      inc = ( start <= end ? 1 : -1 );

      if ( incr != NULL )
         inc *= abs( incr->data.number );

      old_env = local_env;
      local_env = make_atom_from_act_record( make_stack() );
      STACK_PUSH( local_env->data.atom->data.act_record, old_env )

      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_INT( local_env->data.atom->data.act_record, symbol->data.atom->id )

      idx = start;

      while (( inc < 0 ? ( idx >= end ) : ( idx <= end )))
      {
         if ( evaluate_body( args->next, &failed ))
         {
            result = NULL;

            if ( !stop )
               fprintf( stderr, "%s: evaluation of body expression %d failed.\n", syntax, failed );

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

            goto ERROR;
         }

         result = STACK_POP( stack );

      NEXT:
         if ( numberp( ( *act_ptr )->flags ) == 0 )
         {
            fprintf( stderr, "%s: index variable rebound to non-number.\n", syntax );
            result = NULL;
            goto ERROR;
         }

         idx = ( *act_ptr )->data.number + inc;
         *act_ptr = make_atom_from_number( idx );
      }

      /*
       * It is possible for the user to "continue" all the way through the loop
       * without generating a return value.  In that case zero is returned.
       */

      if ( result == NULL )
         result = make_atom_from_number( 0 );

ERROR:
      local_env = old_env;

      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 *result = NULL;
      long int i, old_stack;
      int failed;

      result = STACK_POP( stack );

      if ( numberp( result->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 1, ATOM_FIXNUM );
         return 1;
      }

      old_stack = stack->used;

      for( i = abs( result->data.number ); i; --i )
      {
         if ( evaluate_body( args, &failed ))
         {
            if ( !stop )
               fprintf( stderr, "%s: evaluation of body expression %d failed.\n", syntax, failed );

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

            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: evaluation of body expression %d failed.\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 )
{
   static int proto[] = { 2, ATOM_FIXNUM, ATOM_FIXNUM };

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

   {
      struct object *car1, *car2;
      long int time1, time2;

      car2 = STACK_POP( stack );
      car1 = STACK_POP( stack );

      time1 = car1->data.number;
      time2 = car2->data.number;

      STACK_PUSH( stack, make_atom_from_number( time1 - time2 ))
   }

   return 0;
}

int do_timethen( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      long int then;
      time_t t;
      struct object *car;

      car = STACK_POP( stack );
      then = car->data.number;

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

      STACK_PUSH( stack, make_atom_from_number( t + then ))
   }

   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, ATOM_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, ATOM_FIXNUM );
         return 1;
      }
   }

   {
      int global;
      struct object *value;
      struct stack *local;
      struct object *env_ptr;
      union stack_u *ptr = NULL;

      global = 1;
      value = NULL;

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

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

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

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

   FOUND_0:
      if ( islist( value->flags ) || ! numberp( value->flags ))
      {
         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 : val->data.number ) + value->data.number ))

      if ( global )
         insert_binding( symbol->data.atom, stack->top->ptr );
      else
         ptr->ptr = stack->top->ptr;
   }

   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, ATOM_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, ATOM_FIXNUM );
         return 1;
      }
   }

   {
      int global;
      struct object *value;
      struct stack *local;
      struct object *env_ptr;
      union stack_u *ptr = NULL;

      global = 1;
      value = NULL;

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

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

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

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

   FOUND_0:
      if ( islist( value->flags ) || ! numberp( value->flags ))
      {
         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( value->data.number - ( val == NULL ? 1 : val->data.number )))

      if ( global )
         insert_binding( symbol->data.atom, stack->top->ptr );
      else
         ptr->ptr = stack->top->ptr;
   }

   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, ATOM_SYMBOL );
      return 1;
   }

   STACK_PUSH( stack, args->next )

   if ( evaluate() )
   {
      if ( !stop )
         print_err( ERR_EVAL, syntax, 2, 0 );

      return 1;
   }

   {
      struct stack *local;
      struct object *env_ptr;
      union stack_u *ptr;

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

         for( ptr = local->top; ptr > local->values; ptr -= 2 )
            if ( ptr->integer == symbol->data.atom->id )
            {
               ( --ptr )->ptr = stack->top->ptr;
               return 0;
            }
      }

      insert_binding( symbol->data.atom, stack->top->ptr );
   }

   return 0;
}

int do_child_eof( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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, strlen( encrypted )))
   }

   return 0;
}

int do_loop( char *syntax, struct object *args )
{
   struct object *ptr, *result = NULL;
   long 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: evaluation of body expression %ld failed.\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 )
{
   static int proto[] = { 3, ATOM_FIXNUM, ATOM_FIXNUM, ATOM_FIXNUM };

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

   {
      struct date dt;
      struct object *obj;
      int days;

      obj = STACK_POP( stack );
      dt.d = obj->data.number;

      obj = STACK_POP( stack );
      dt.m = obj->data.number;

      obj = STACK_POP( stack );
      dt.y = obj->data.number;

      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 )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      struct date dt;
      struct object *obj;

      obj = STACK_POP( stack );

      if ( obj->data.number < 0 )
      {
         fprintf( stderr, "%s: argument less than 0: %ld.\n", syntax, obj->data.number );
         return 1;
      }

      if ( gdate( obj->data.number, &dt ) == NULL )
      {
         fprintf( stderr, "%s: gdate() 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 )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      struct object *obj;
      int year, wk;

      obj = STACK_POP( stack );

      if (( wk = week( obj->data.number, &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 )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      static char *dtable[] = { "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday" };
      struct object *obj;
      int wkday;

      obj = STACK_POP( stack );

      if (( wkday = weekday( obj->data.number )) < 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 ], strlen( dtable[ wkday ] ));

      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;
      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, ATOM_FIXNUM );
            return 1;
         }

         tm.tm_sec = obj->data.number;
      }
      else
         tm.tm_sec = 0;

      if ( min )
      {
         obj = STACK_POP( stack );

         if ( numberp( obj->flags ) == 0 )
         {
            print_err( ERR_ARG_TYPE, syntax, 5, ATOM_FIXNUM );
            return 1;
         }

         tm.tm_min = obj->data.number;
      }
      else
         tm.tm_min = 0;

      if ( hour )
      {
         obj = STACK_POP( stack );

         if ( numberp( obj->flags ) == 0 )
         {
            print_err( ERR_ARG_TYPE, syntax, 4, ATOM_FIXNUM );
            return 1;
         }

         tm.tm_hour = obj->data.number;
      }
      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, ATOM_FIXNUM );
         return 1;
      }

      tm.tm_mday = obj->data.number;

      obj = STACK_POP( stack );

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

      tm.tm_mon = obj->data.number - 1;

      obj = STACK_POP( stack );

      if ( numberp( obj->flags ) == 0 )
      {
         print_err( ERR_ARG_TYPE, syntax, 1, ATOM_FIXNUM );
         return 1;
      }

      tm.tm_year = obj->data.number - 1900;
      tm.tm_yday = -1;

      if (( t = mktime( &tm )) == -1 && tm.tm_yday == -1 )
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), -1 ))
      else
         STACK_PUSH( stack, make_atom_from_number( t ))
   }

   return 0;
}

int broken_time( char *syntax, struct object *args, int utc )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      struct object *obj;
      struct tm *tm;
      time_t t;

      obj = STACK_POP( stack );
      t = obj->data.number;

      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 )
{
   static int proto[] = { 1, ATOM_FIXNUM };

   if ( check_args( syntax, args, proto ))
      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 = obj->data.number;

      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 ], strlen( months[ m - 1] )))
   }

   return 0;
}

int do_negate( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      long int i;
      struct object *car;

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

      STACK_PUSH( stack, make_atom_from_number( -i ))
   }

   return 0;
}

int do_getpid( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   STACK_PUSH( stack, make_atom_from_number( ( int )getpid() ) )

   return 0;
}

int do_getppid( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   STACK_PUSH( stack, make_atom_from_number( ( int )getppid() ))

   return 0;
}

int do_setpgid( char *syntax, struct object *args )
{
   static int proto[] = { 2, ATOM_FIXNUM, ATOM_FIXNUM };

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

   {
      struct object *car1, *car2;

      car2 = STACK_POP( stack );
      car1 = STACK_POP( stack );

      if ( setpgid( ( pid_t )car1->data.number, ( pid_t )car2->data.number ) < 0 )
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      else
         STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_getpgrp( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   STACK_PUSH( stack, make_atom_from_number( getpgrp() ))

   return 0;
}

int do_tcgetpgrp( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 ), strlen( strerror( errno ))))
         else
            STACK_PUSH( stack, make_atom_from_number( pid ))
      }
   }

   return 0;
}

int do_tcsetpgrp( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_FIXNUM };

   if ( check_args( syntax, args, proto ))
      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 )car->data.number ) < 0 )
            STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
         else
            STACK_PUSH( stack, make_atom_from_number( 1 ))
      }
   }

   return 0;
}

int do_kill( char *syntax, struct object *args )
{
   static int proto[] = { 2, ATOM_FIXNUM, ATOM_FIXNUM };

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

   {
      struct object *car1, *car2;

      car2 = STACK_POP( stack );
      car1 = STACK_POP( stack );

      if ( kill( ( pid_t )car1->data.number, car2->data.number ) < 0 )
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      else
         STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_killpg( char *syntax, struct object *args )
{
   static int proto[] = { 2, ATOM_FIXNUM, ATOM_FIXNUM };

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

   {
      struct object *car1, *car2;

      car2 = STACK_POP( stack );
      car1 = STACK_POP( stack );

      if ( killpg( ( pid_t )car1->data.number, car2->data.number ) < 0 )
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      else
         STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_fork( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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_INT( descriptors[ wrt ], flag )

         if ( wrt )
            fclose(( wrt == 1 ? stdout : stderr ));

         if ( dup2( fd[ 0 ], wrt ) < 0 )
         {
            close( fd[ 0 ] );
            close( STACK_POP_INT( 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 )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      long int i;
      struct object *car;

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

      if ( i < 0 || i > 2 )
      {
         fprintf( stderr, "%s: descriptor argument out of range: %ld\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, ATOM_FIXNUM );
         return 1;
      }

      i = car1->data.number;

      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", 6 );
      }
      else if ( WIFEXITED( status ))
      {
         obj->data.head->next = make_atom_from_symbol( "EXITED", 6 );
         obj->data.head->next->next = make_atom_from_number( WEXITSTATUS( status ) );
      }
      else if ( WIFSTOPPED( status ))
      {
         obj->data.head->next = make_atom_from_symbol( "STOPPED", 7 );
         obj->data.head->next->next = make_atom_from_number( WSTOPSIG( status ));
      }
      else if ( WIFSIGNALED( status ))
      {
         obj->data.head->next = make_atom_from_symbol( "KILLED", 6 );
         obj->data.head->next->next = make_atom_from_number( WTERMSIG( status ));
      }
   }

   return 0;
}

int do_zombies( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   STACK_PUSH( stack, make_atom_from_number( 1 ))
   zombies = 1;

   return 0;
}

int do_nozombies( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   STACK_PUSH( stack, make_atom_from_number( 1 ))
   zombies = 0;

   return 0;
}

int do_glob( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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, strlen( *path ));

      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_INT( descriptors[ std ], 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 )
{
   static int proto[] = { 0 };

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

   return dup_std( syntax, 2 );
}

int do_stdout2stderr( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   return dup_std( syntax, 1 );
}

int nth( char *syntax, struct object *list, long 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: %ld.\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 )
{
   static int proto[] = { 2, ATOM_LIST, ATOM_FIXNUM };

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

   {
      long int i;
      struct object *car1, *car2;

      car2 = STACK_POP( stack );
      car1 = STACK_POP( stack );

      i = car2->data.number;

      return nth( syntax, car1, i, 0 );
   }
}

int do_nthcdr( char *syntax, struct object *args )
{
   static int proto[] = { 2, ATOM_LIST, ATOM_FIXNUM };

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

   {
      long int i;
      struct object *car1, *car2;

      car2 = STACK_POP( stack );
      car1 = STACK_POP( stack );

      i = car2->data.number;

      return nth( syntax, car1, i, 1 );
   }
}

int do_reset_history( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 0 };

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

   STACK_PUSH( stack, make_atom_from_number( zombies ))

   return 0;
}

int do_dec2hex( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      struct object *obj;
      char buffer[ 64 ];
      long int len;

      obj = STACK_POP( stack );
      len = snprintf( buffer, sizeof( buffer ), "%lX", obj->data.number );

      STACK_PUSH( stack, make_atom_from_string( buffer, len ))
   }

   return 0;
}

int do_hex2dec( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_STRING };

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

   {
      struct object *obj;
      long 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 start_listening( char *interface, char *port )
{
   struct addrinfo hints, *res;
   char buffer[ 128 ];
   int result;

   bzero( &hints, sizeof( struct addrinfo ));
   hints.ai_flags = AI_PASSIVE;
   hints.ai_socktype = SOCK_STREAM;

   if (( result = getaddrinfo( interface, port, &hints, &res )))
   {
      int len;

      len = snprintf( buffer, sizeof( buffer ), "getaddrinfo(): %s", gai_strerror( result ));
      STACK_PUSH( stack, make_atom_from_string( buffer, len ))
      return 0;
   }

   if ( res == NULL )
   {
      char *err = "getaddrinfo(): no interface found";
      STACK_PUSH( stack, make_atom_from_string( err, strlen( err )))
      return 0;
   }

   serv_fd = socket( res->ai_family, res->ai_socktype, res->ai_protocol );

   if ( serv_fd == -1 )
   {
      int len;

      if ( res != NULL )
         freeaddrinfo( res );
      len = snprintf( buffer, sizeof( buffer ), "socket(): %s", strerror( errno ));
      STACK_PUSH( stack, make_atom_from_string( buffer, len ))
      return 0;
   }

   result = 1;

   setsockopt( serv_fd, SOL_SOCKET, SO_REUSEPORT, &result, sizeof( result ));
   setsockopt( serv_fd, SOL_SOCKET, SO_KEEPALIVE, &result, sizeof( result ));

   result = 0;

   if ( interface == NULL )
      setsockopt( serv_fd, IPPROTO_IPV6, IPV6_BINDV6ONLY, &result, sizeof( result ));

   if ( bind( serv_fd, res->ai_addr, res->ai_addrlen ) < 0 )
   {
      int len;

      close( serv_fd );
      if ( res != NULL )
         freeaddrinfo( res );
      serv_fd = -1;

      len = snprintf( buffer, sizeof( buffer ), "bind(): %s", strerror( errno ));
      STACK_PUSH( stack, make_atom_from_string( buffer, len ))
      return 0;
   }

   if ( res != NULL )
      freeaddrinfo( res );

   if ( listen( serv_fd, 4096 ) < 0 )
   {
      int len;

      close( serv_fd );
      serv_fd = -1;

      len = snprintf( buffer, sizeof( buffer ), "listen(): %s", strerror( errno  ));
      STACK_PUSH( stack, make_atom_from_string( buffer, len ))
      return 0;
   }

   fcntl( serv_fd, F_SETFD, FD_CLOEXEC );
   STACK_PUSH( stack, make_atom_from_number( strtol( port, NULL, 10 )))

   return 0;
}

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

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

   {
      int num;
      char buffer[ 64 ];

      if ( islist( car1->flags ) ||
           ( ( num = numberp( car1->flags )) == 0 &&
             type( car1->data.atom->flags ) != ATOM_STRING ))
      {
         print_err( ERR_ARG_TYPE, syntax, 1, ATOM_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, ATOM_STRING );
         return 1;
      }

      if ( serv_fd >= 0 )
      {
         char *err = "already listening";
         STACK_PUSH( stack, make_atom_from_string( err, strlen( err )))
         return 0;
      }

      if ( num )
         snprintf( buffer, sizeof( buffer ), "%ld", car1->data.number );

      return start_listening( ( car2 == NULL ? NULL : car2->data.atom->data.string->string ),
                              ( num ? buffer : car1->data.atom->data.string->string ) );
   }
}

int do_listen_unix( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_STRING };

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

   {
      int fd;
      char buffer[ 128 ];
      struct sockaddr_un sa;
      struct object *car;

      car = STACK_POP( stack );

      if ( serv_fd >= 0 )
      {
         char *err = "already listening";
         STACK_PUSH( stack, make_atom_from_string( err, strlen( err )))
         return 0;
      }

      if (( fd = socket( PF_LOCAL, SOCK_STREAM, 0 )) < 0 )
      {
         int len;

         len = snprintf( buffer, sizeof( buffer ), "socket(): %s", strerror( errno ));
         STACK_PUSH( stack, make_atom_from_string( buffer, len ))
         return 0;
      }

      unlink( car->data.atom->data.string->string );
      bzero( &sa, sizeof( struct sockaddr_un ));
      strncpy( sa.sun_path, car->data.atom->data.string->string,
               sizeof( sa.sun_path ) - 1 );  /* ensures NULL-terminated. */

      if ( bind( fd, ( struct sockaddr *)&sa, SUN_LEN( &sa )))
      {
         int len;

         close( fd );
         len = snprintf( buffer, sizeof( buffer ), "bind(): %s", strerror( errno ));
         STACK_PUSH( stack, make_atom_from_string( buffer, len ))
         return 0;
      }

      serv_fd = fd;

      if ( listen( serv_fd, 32768 ) < 0 )
      {
         int len;

         close( serv_fd );
         serv_fd = -1;
         len = snprintf( buffer, sizeof( buffer ), "listen(): %s", strerror( errno ));
         STACK_PUSH( stack, make_atom_from_string( buffer, len ))
         return 0;
      }

      fcntl( serv_fd, F_SETFD, FD_CLOEXEC );
      unix_server = 1;
      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_accept( char *syntax, struct object *args )
{
   int dupin, dupout, fd, oe;
   static int proto[] = { 0 };

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

   if ( serv_fd < 0 )
   {
      char *err = "\"listen\" or \"listen_unix\" has not been invoked";
      STACK_PUSH( stack, make_atom_from_string( err, strlen( err )))
      return 0;
   }

AGAIN:
   set_sigterm_intr();
   fd = accept( serv_fd, NULL, 0 );

   oe = errno;
   signal( SIGTERM, sigterm_handler );
   errno = oe;

   if ( fd < 0 )
   {
      if ( errno == EAGAIN || errno == EINTR )
      {
         if ( ! sigterm )
            goto AGAIN;

         STACK_PUSH( stack, make_atom_from_number( -1 ))
         return 0;
      }

      STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      return 0;
   }

   if (( dupin = dup( 0 )) < 0 )
   {
      STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      return 0;
   }

   if (( dupout = dup( 1 )) < 0 )
   {
      close( dupin );
      STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      return 0;
   }

   STACK_PUSH_INT( descriptors[ 0 ], dupin )
   STACK_PUSH_INT( descriptors[ 1 ], 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 ), strlen( strerror( errno ))))
      return 0;
   }

   if ( dup2( fd, 1 ) < 0 )
   {
      close( fd );
      resume( syntax, 0 );
      resume( syntax, 1 );
      STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      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 ), strlen( strerror( errno ))))
      return 0;
   }

   STACK_PUSH( stack, make_atom_from_number( 1 ))
   return 0;
}

int do_daemonize( char *syntax, struct object *args )
{
   struct object *car;
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 )
   {
      char *err = "\"daemonize\" has not been invoked";
      STACK_PUSH( stack, make_atom_from_string( err, strlen( err )))
      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, "ERROR" ))
         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, "%s", msg->str );
      string_free( msg );
   }

   return 0;
}

int do_stop_listening( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   if ( serv_fd >= 0 )
   {
      close( serv_fd );
      serv_fd = -1;
      unix_server = 0;
      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 )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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->ptr;
      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_truncate( stack, stack->used - i );
      STACK_POP( stack );

      get_token( 0, -1 );
      ++string_counter;

      STACK_PUSH( stack, car )
   }

   return 0;
}

int do_blind_eval_string( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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->ptr;

      STACK_PUSH( open_envs, local_env )
      local_env = NULL;

      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 previous local_env and the argument string.
       */

      local_env = STACK_POP( open_envs );

      stack_truncate( stack, stack->used - i );
      STACK_POP( stack );

      get_token( 0, -1 );
      ++string_counter;

      STACK_PUSH( stack, car )
   }

   return 0;
}

int do_flush_stdout( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   fflush( stdout );

   STACK_PUSH( stack, make_atom_from_number( 1 ))
   return 0;
}

int do_getpeername( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   if ( serv_fd < 0 )
   {
      fprintf( stderr, "%s:  \"listen\" has not been invoked.\n", syntax );
      return 1;
   }

   {
      struct sockaddr_storage addr;
      socklen_t len;
      char address[ 128 ];
      const char *ptr = NULL;

      len = sizeof( struct sockaddr_storage );

      if ( getpeername( STDIN_FILENO, ( struct sockaddr *)&addr, &len ) < 0 )
         strcpy( address, "unknown" );
      else if ( addr.ss_family == AF_INET6 )
         ptr = inet_ntop( AF_INET6, &(( struct sockaddr_in6 *)&addr )->sin6_addr,
                          address, sizeof( address ));
      else if ( addr.ss_family == AF_INET )
         ptr = inet_ntop( AF_INET, &(( struct sockaddr_in *)&addr )->sin_addr,
                          address, sizeof( address ));

      if ( ptr == NULL )
         strcpy( address, "unknown" );

      STACK_PUSH( stack, make_atom_from_string( address, strlen( address )))
   }

   return 0;
}

int do_temporary( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   {
      char filename[] = "/tmp/mungerXXXXXXXXXX";
      int fd, dupout;

      if (( fd = mkstemp( filename )) < 0 )
      {
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
         return 0;
      }

      if (( dupout = dup( 1 )) < 0 )
      {
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
         return 0;
      }

      STACK_PUSH_INT( descriptors[ 1 ], dupout )

      fclose( stdout );
      stdout = NULL;

      if ( dup2( fd, 1 ) < 0 )
      {
         close( fd );
         resume( syntax, 1 );
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
         return 0;
      }

      close( fd );
      stdout = fdopen( 1, "w" );

      if ( stdout == NULL )
      {
         resume( syntax, 1 );
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
         return 0;
      }

      STACK_PUSH( stack, make_atom_from_string( filename, strlen( filename )))
   }

   return 0;
}

int get_token_from_buffer( char *syntax, int buff )
{
   static char *ptr = NULL, *orig = NULL;
   static recno_t 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 ].ptr )->seq(
                            ( DB *)buffer_stack->values[ buff ].ptr, &dbt_key,
                            &dbt_value, R_LAST )) == -1 )
         {
            fprintf( stderr, "%s: db->seq: %s.\n", syntax, strerror( errno ));
            return TOK_END;
         }

         if ( result == 1 || line > *( recno_t *)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 ].ptr )->get(
                            ( DB *)buffer_stack->values[ buff ].ptr, &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;
   static int proto[] = { 0 };

   if ( check_args( syntax, args, proto ))
      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 = car->data.number;

      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 ].ptr )
            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 )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 ), strlen( strerror( errno ))))
      else
         STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_setgid( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 ), strlen( strerror( errno ))))
      else if ( setgid( group->gr_gid ) < 0 )
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      else
         STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_setegid( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_STRING };

   if ( check_args( syntax, args, proto ))
      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 ), strlen( strerror( errno ))))
      else if ( setegid( group->gr_gid ) < 0 )
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      else
         STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_getline_ub( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_FIXNUM };

   if ( args != NULL && check_args( syntax, args, proto ))
      return 1;

   {
      int timeout, r, count;
      char c;
      struct string *s;
      struct itimerval value;

      timeout = 0;

      if ( args != NULL )
      {
         struct object *ptr;

         ptr = STACK_POP( stack );
         timeout = ptr->data.number;

         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;

            set_sigalrm_intr();
            setitimer( ITIMER_REAL, &value, NULL );
         }

         if (( r = read( 0, &c, 1 )) <= 0 )
            break;

         STRING_APPEND( s, c )

         if ( c == 10 || ++count == 2048 )
            break;
      }

      if ( timeout )
      {
         int oe = errno;

         value.it_value.tv_sec = 0;
         value.it_value.tv_usec = 0;

         signal( SIGALRM, sigalrm_handler );
         setitimer( ITIMER_REAL, &value, NULL );
         errno = oe;
      }

      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_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 )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      struct object *car;
      int n;

      car = STACK_POP( stack );
      n = car->data.number;

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

int redirect_descriptors( int *fd, char *syntax )
{
   int dupin, dupout;

   if (( dupin = dup( 0 )) < 0 )
   {
      STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      return 0;
   }

   if (( dupout = dup( 1 )) < 0 )
   {
      close( dupin );
      STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      return 0;
   }

   STACK_PUSH_INT( descriptors[ 0 ], dupin )
   STACK_PUSH_INT( descriptors[ 1 ], dupout )

   fclose( stdout );
   stdout = NULL;

   if ( dup2( fd[ 0 ], 0 ) < 0 )
   {
      close( fd[ 0 ] );
      resume( syntax, 0 );
      resume( syntax, 1 );
      STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      return 0;
   }

   if ( dup2( fd[ 1 ], 1 ) < 0 )
   {
      close( fd[ 1 ] );
      resume( syntax, 0 );
      resume( syntax, 1 );
      STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      return 0;
   }

   close( fd[ 0 ] );
   close( fd[ 1 ] );
   stdout = fdopen( 1, "w" );

   if ( stdout == NULL )
   {
      resume( syntax, 0 );
      resume( syntax, 1 );
      STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
      return 0;
   }

   STACK_PUSH( stack, make_atom_from_number( 1 ))
   return 0;
}

int do_receive_descriptors( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   if ( !unix_server )
   {
      char *err = "receive_descriptors: listen_unix has not been invoked";
      STACK_PUSH( stack, make_atom_from_string( err, strlen( err )))
      return 0;
   }

   {
      struct msghdr msg;
      struct iovec iov[ 1 ];
      ssize_t n;
      int i, newfd[ 2 ];
      char buffer[ 128 ];

      union {
         struct cmsghdr cm;
         char control[ CMSG_SPACE( sizeof( int )) ];
      } control_un;

      struct cmsghdr *cmptr;

      msg.msg_control = control_un.control;
      msg.msg_controllen = sizeof( control_un.control );
      msg.msg_name = NULL;
      msg.msg_namelen = 0;

      iov[ 0 ].iov_base = buffer;
      iov[ 0 ].iov_len = sizeof( buffer );
      msg.msg_iov = iov;
      msg.msg_iovlen = 1;

      for( i = 0; i < 2; ++i )
      {
         if (( n = recvmsg( 0, &msg, 0 )) < 0 )
         {
            int len;

            len = snprintf( buffer, sizeof( buffer ), "%s: recvmsg(): %s", syntax, strerror( errno ));
            STACK_PUSH( stack, make_atom_from_string( buffer, len ))
            return 0;
         }

         if (( cmptr = CMSG_FIRSTHDR( &msg )) == NULL ||
               cmptr->cmsg_len != CMSG_LEN( sizeof( int )))
         {
            char *err = "receive_descriptors: message did not contain descriptor";
            STACK_PUSH( stack, make_atom_from_string( err, strlen( err )))
            return 0;
         }

         if ( cmptr->cmsg_level != SOL_SOCKET )
         {
            char *err = "receive_descriptors: control level != SOL_SOCKET";
            STACK_PUSH( stack, make_atom_from_string( err, strlen( err )))
            return 0;
         }

         if ( cmptr->cmsg_type != SCM_RIGHTS )
         {
            char *err = "receive_descriptors: control type != SCM_RIGHTS";
            STACK_PUSH( stack, make_atom_from_string( err, strlen( err )))
            return 0;
         }

         newfd[ i ] = *( int *)( CMSG_DATA( cmptr ) );
      }

      redirect_descriptors( newfd, syntax );
   }

   return 0;
}

int do_send_descriptors( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   if ( child_pid != -3 )
   {
      char *err = "send_descriptors: not connected to UNIX domain server";
      STACK_PUSH( stack, make_atom_from_string( err, strlen( err )))
      return 0;
   }

   {
      struct msghdr msg;
      struct iovec iov[ 1 ];
      char buffer[ 128 ];
      int i;

      union {
         struct cmsghdr cm;
         char control[ CMSG_SPACE( sizeof( int )) ];
      } control_un;

      struct cmsghdr *cmptr;

      for( i = 0; i < 2; ++i )
      {
         msg.msg_control = control_un.control;
         msg.msg_controllen = sizeof( control_un.control );
         msg.msg_name = NULL;
         msg.msg_namelen = 0;

         cmptr = CMSG_FIRSTHDR( &msg );
         cmptr->cmsg_len = CMSG_LEN( sizeof( int ));
         cmptr->cmsg_level = SOL_SOCKET;
         cmptr->cmsg_type = SCM_RIGHTS;

         *( int *)( CMSG_DATA( cmptr )) = i;

         iov[ 0 ].iov_base = buffer;
         iov[ 0 ].iov_len = sizeof( buffer );
         msg.msg_iov = iov;
         msg.msg_iovlen = 1;

         if ( sendmsg( child_fd, &msg, 0 ) < 0 )
         {
            int len;

            len = snprintf( buffer, sizeof( buffer ), "send_descriptors: sendmsg(): %s", strerror( errno ));
            STACK_PUSH( stack, make_atom_from_string( buffer, len ))
            return 0;
         }
      }

      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_busymap( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   if ( shared_map != NULL )
   {
      STACK_PUSH( stack, make_atom_from_number( -1 ))
      return 0;
   }

   {
      struct object *car;

      car = STACK_POP( stack );

      if ( car->data.number <= 0 )
      {
         fprintf( stderr, "%s: argument out of range: %ld.\n", syntax,
                  car->data.number );
         return 1;
      }

      if (( shared_map = mmap( 0, car->data.number, PROT_WRITE | PROT_READ,
                               MAP_ANON | MAP_SHARED, -1, 0 )) == NULL )
      {
         fprintf( stderr, "%s: mmap(): %s.\n", syntax, strerror( errno ));
         return 1;
      }

      shared_len = car->data.number;

      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_nobusymap( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   if ( shared_map == NULL )
   {
      STACK_PUSH( stack, make_atom_from_number( -1 ))
      return 0;
   }

   if ( munmap( shared_map, shared_len ) )
   {
      fprintf( stderr, "%s: munmap(): %s.\n", syntax, strerror( errno ));
      return 1;
   }

   shared_map = NULL;
   shared_len = 0;

   STACK_PUSH( stack, make_atom_from_number( 1 ))

   return 0;
}

int do_busy( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   if ( shared_map == NULL )
   {
      STACK_PUSH( stack, make_atom_from_number( -1 ))
      return 0;
   }

   {
      struct object *car;

      car = STACK_POP( stack );

      if ( car->data.number < 0 || car->data.number >= shared_len )
      {
         fprintf( stderr, "%s: argument out of range: %ld.\n", syntax,
                  car->data.number );
         return 1;
      }

      shared_map[ car->data.number ] = 1;
      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_notbusy( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   if ( shared_map == NULL )
   {
      STACK_PUSH( stack, make_atom_from_number( -1 ))
      return 0;
   }

   {
      struct object *car;

      car = STACK_POP( stack );

      if ( car->data.number < 0 || car->data.number >= shared_len )
      {
         fprintf( stderr, "%s: argument out of range: %ld.\n", syntax,
                  car->data.number );
         return 1;
      }

      shared_map[ car->data.number ] = 0;
      STACK_PUSH( stack, make_atom_from_number( 1 ))
   }

   return 0;
}

int do_busyp( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   if ( shared_map == NULL )
   {
      STACK_PUSH( stack, make_atom_from_number( -1 ))
      return 0;
   }

   {
      struct object *car;

      car = STACK_POP( stack );

      if ( car->data.number < 0 || car->data.number >= shared_len )
      {
         fprintf( stderr, "%s: argument out of range: %ld.\n", syntax,
                  car->data.number );
         return 1;
      }

      STACK_PUSH( stack,
                  make_atom_from_number( shared_map[ car->data.number ] ))
   }

   return 0;
}


int do_sleep( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_FIXNUM };

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

   {
      struct object *car;
      long int r;

      car = STACK_POP( stack );

      if ( car->data.number < 0 )
      {
         fprintf( stderr, "%s: argument < 0: %ld", syntax, car->data.number );
         return 1;
      }

      r = sleep( car->data.number );

      STACK_PUSH( stack, make_atom_from_number( r ))
   }

   return 0;
}

char *find_next( char *ptr )
{
   while( --scgi_header_len )
      if ( ! *ptr++ )
         break;

   if ( ! scgi_header_len )
      return NULL;

   return ptr;
}

void init_env( char *header )
{
   struct object **result;
   char *ptr;
   int n;

   STACK_PUSH( stack, make_object() )
   setlist( (( struct object *)stack->top->ptr )->flags );
   result = &(( struct object *)stack->top->ptr )->data.head;

   for( n = 0, ptr = header; ptr != NULL; ptr = find_next( ptr ), ++n )
   {
      *result = make_atom_from_string( ptr, strlen( ptr ));
      result = &( *result )->next;
   }

   if ( n % 2 )
   {
      STACK_POP( stack );
      STACK_PUSH( stack, make_atom_from_number( 0 ))
   }

   return;
}

int do_get_scgi_header( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   {
      char *ptr, buffer[ 64 ], *header, c;
      int i, x;

      for( i = 0, ptr = buffer; i < sizeof( buffer ); ++ptr, ++i )
      {
         if ( read( 0, &c, 1 ) <= 0 )
         {
            STACK_PUSH( stack, make_atom_from_number( 0 ))
            return 0;
         }

         if ( c == ':' )
         {
            *ptr = '\0';
            break;
         }

         *ptr = c;
      }

      if ( c != ':' )
      {
         STACK_PUSH( stack, make_atom_from_number( 0 ))
         return 0;
      }

      if (( scgi_header_len = strtol( buffer, NULL, 10 )) <= 0 )
      {
         STACK_PUSH( stack, make_atom_from_number( 0 ))
         return 0;
      }

      header = memory( scgi_header_len );

      for( i = scgi_header_len, ptr = header; i > 0; i -= x, ptr += x )
      {
         if (( x = read( 0, ptr, i )) <= 0 )
         {
            free( header );
            STACK_PUSH( stack, make_atom_from_number( 0 ))
            return 0;
         }
      }

      if ( read( 0, &c, 1 ) <= 0 )
      {
         free( header );
         STACK_PUSH( stack, make_atom_from_number( 0 ))
         return 1;
      }

      init_env( header );
      free( header );
   }

   return 0;
}

int do_form_decode( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_STRING };

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

   {
      struct object *car;
      char *ptr;
      struct string *s;

      car = STACK_POP( stack );
      s = make_string();
      STRING_APPEND( s, '"' )

      for( ptr = car->data.atom->data.string->string; *ptr; ++ptr )
         switch( *ptr )
         {
            case '+':
               STRING_APPEND( s, ' ' )
               break;

            case '%':
               if ( ! *( ptr + 1 ) || ! *( ptr + 2 ))
                  STRING_APPEND( s, *ptr )
               else
               {
                  char data[ 3 ];
                  char code;

                  data[ 0 ] = *( ptr + 1 );
                  data[ 1 ] = *( ptr + 2 );
                  data[ 2 ] = '\0';

                  if (( code = ( char )strtol( data, NULL, 16 )))
                  {
                     STRING_APPEND( s, code )
                     ptr += 2;
                  }
                  else
                     STRING_APPEND( s, *ptr )
               }
               break;

            default:
               STRING_APPEND( s, *ptr )
         }


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

   return 0;
}

int do_form_encode( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_STRING };

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

   {
      struct object *car;
      char *ptr, *ptr2;
      struct string *s;
      int found;
      static char *reserved = "]$;:@&+!?=#{}/[^`~\"<>|%\\\t\r\n",
                  *letters  = "0123456789ABCDEF";

      car = STACK_POP( stack );
      s = make_string();
      STRING_APPEND( s, '"' )

      for( ptr = car->data.atom->data.string->string; *ptr; ++ptr )
      {
         found = 0;

         if ( *ptr == ' ' )
         {
            STRING_APPEND( s, '+' )
            continue;
         }

         for( ptr2 = reserved; *ptr2; ++ptr2 )
            if ( *ptr == *ptr2 )
            {
               STRING_APPEND( s, '%' )
               STRING_APPEND( s, letters[ *ptr / 16 ] )
               STRING_APPEND( s, letters[ *ptr % 16 ] )
               found = 1;
               break;
            }

         if ( ! found )
            STRING_APPEND( s, *ptr )
      }

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

   return 0;
}

int foreground( char *syntax, struct object *args, int color )
{
   static int proto[] = { 0 };

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

   if ( af == ( char *)-1 )
   {
      fprintf( stderr, "%s: terminal has insufficient capabilities.\n",
               syntax );
      return 1;
   }

   putp( tparm( af, color ));
   fflush( stdout );
   STACK_PUSH( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_fg_black( char *syntax, struct object *args )
{
   return foreground( syntax, args, COLOR_BLACK );
}

int do_fg_red( char *syntax, struct object *args )
{
   return foreground( syntax, args, COLOR_RED );
}

int do_fg_green( char *syntax, struct object *args )
{
   return foreground( syntax, args, COLOR_GREEN );
}

int do_fg_yellow( char *syntax, struct object *args )
{
   return foreground( syntax, args, COLOR_YELLOW );
}

int do_fg_blue( char *syntax, struct object *args )
{
   return foreground( syntax, args, COLOR_BLUE );
}

int do_fg_magenta( char *syntax, struct object *args )
{
   return foreground( syntax, args, COLOR_MAGENTA );
}

int do_fg_cyan( char *syntax, struct object *args )
{
   return foreground( syntax, args, COLOR_CYAN );
}

int do_fg_white( char *syntax, struct object *args )
{
   return foreground( syntax, args, COLOR_WHITE );
}

int background( char *syntax, struct object *args, int color )
{
   static int proto[] = { 0 };

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

   if ( ab == ( char *)-1 )
   {
      fprintf( stderr, "%s: terminal has insufficient capabilities.\n",
               syntax );
      return 1;
   }

   putp( tparm( ab, color ));
   fflush( stdout );
   STACK_PUSH( stack, make_atom_from_number( 1 ));

   return 0;
}

int do_bg_black( char *syntax, struct object *args )
{
   return background( syntax, args, COLOR_BLACK );
}

int do_bg_red( char *syntax, struct object *args )
{
   return background( syntax, args, COLOR_RED );
}

int do_bg_green( char *syntax, struct object *args )
{
   return background( syntax, args, COLOR_GREEN );
}

int do_bg_yellow( char *syntax, struct object *args )
{
   return background( syntax, args, COLOR_YELLOW );
}

int do_bg_blue( char *syntax, struct object *args )
{
   return background( syntax, args, COLOR_BLUE );
}

int do_bg_magenta( char *syntax, struct object *args )
{
   return background( syntax, args, COLOR_MAGENTA );
}

int do_bg_cyan( char *syntax, struct object *args )
{
   return background( syntax, args, COLOR_CYAN );
}

int do_bg_white( char *syntax, struct object *args )
{
   return background( syntax, args, COLOR_WHITE );
}

int do_save_history( char *syntax, struct object *args )
{
   struct object *car;
   static int proto[] = { 1, ATOM_STRING };
   long int i, fd;
   mode_t mode;
   char *ptr;

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

   car = STACK_POP( stack );

   if (( ptr = setmode( "0600" )) == NULL )
   {
      fprintf( stderr, "%s: setmode(): %s.\n", syntax, strerror( errno ));
      return 1;
   }

   mode = getmode( ptr, 0 );
   free( ptr );

   if (( fd = open( car->data.atom->data.string->string,
                    O_WRONLY | O_CREAT | O_TRUNC | O_EXLOCK | O_NONBLOCK, mode )) < 0 )
      STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
   else
   {
      for( i = 0; i < history->used; ++i )
      {
         if ( write( fd, history->values[ i ].ptr, strlen( history->values[ i ].ptr )) < 0 )
         {
            STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
            break;
         }

         if ( write( fd, "\n", 1 ) < 0 )
         {
            STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
            break;
         }
      }
   }

   close( fd );
   STACK_PUSH( stack, make_atom_from_number( history->used ));

   return 0;
}

struct string *read_history( int fd )
{
   static struct string *s = NULL;
   int result;
   static char *ptr = NULL, *ptr2 = NULL;
   static char input_buffer[ 131072 ] = "";

   if ( s == NULL )
      s = make_string();
   else
   {
      s->free += s->used;
      s->used = 0;
      s->top = s->str;
   }

READ:
   if ( ! *input_buffer )
   {
      result = read( fd, input_buffer, sizeof( input_buffer ) - 1 );

      if ( result < 0 )
      {
         fprintf( stderr, "load_history: read: %s.\n", strerror( errno ));
         goto RETURN;
      }
      else if ( ! result )
         goto RETURN;
      else
      {
         input_buffer[ result ] = '\0';
         ptr = input_buffer;
      }
   }

   ptr2 = ptr;

   if (( ptr = strchr( ptr, '\n' )) == NULL )
   {
      while( *ptr2 )
         STRING_APPEND( s, *ptr2++ )

      *input_buffer = '\0';
      goto READ;
   }
   else
   {
      *ptr++ = '\0';

      while( *ptr2 )
         STRING_APPEND( s, *ptr2++ )

      return s;
   }

   *input_buffer = '\0';

RETURN:
   return ( s->used ? s : NULL );
}

int do_load_history( char *syntax, struct object *args )
{
   struct object *car;
   static int proto[] = { 1, ATOM_STRING };
   int fd;

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

   car = STACK_POP( stack );

   if (( fd = open( car->data.atom->data.string->string, O_RDONLY | O_SHLOCK | O_NONBLOCK )) < 0 )
   {
      if ( errno == ENOENT )
         STACK_PUSH( stack, make_atom_from_number( 0 ))
      else
         STACK_PUSH( stack, make_atom_from_string( strerror( errno ), strlen( strerror( errno ))))
   }
   else
   {
      struct string *s;

      while( history->used )
         STACK_POP( history );

      while(( s = read_history( fd )) != NULL )
         STACK_PUSH( history, str_dup( s->str, s->used ));

      history_ptr = history->used;
      close( fd );
   }

   STACK_PUSH( stack, make_atom_from_number( history->used ));

   return 0;
}

int do_sigtermp( char *syntax, struct object *args )
{
   static int proto[] = { 0 };

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

   STACK_PUSH( stack, make_atom_from_number( sigterm ))
   sigterm = 0;

   return 0;
}

int do_file2string( char *syntax, struct object *args )
{
   static int proto[] = { 1, ATOM_STRING };
   struct object *car;
   int fd;
   struct stat st;
   char *data;

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

   car = STACK_POP( stack );

   if (( fd = open( car->data.atom->data.string->string, O_RDONLY )) < 0 )
   {
      STACK_PUSH( stack, make_atom_from_number( 0 ))
      return 0;
   }

   if ( fstat( fd, &st ) < 0 )
   {
      close( fd );
      STACK_PUSH( stack, make_atom_from_number( 0 ))
      return 0;
   }

   if ( st.st_size >= LONG_MAX )
   {
      STACK_PUSH( stack, make_atom_from_number( 0 ))
      close( fd );
      return 0;
   }

   data = memory( st.st_size + 2 );
   data[ 0 ] = '"';
   data[ st.st_size + 1 ] = '\0';

   if ( read( fd, &data[ 1 ], st.st_size ) < 0 )
   {
      STACK_PUSH( stack, make_atom_from_number( 0 ))
      free( data );
      close( fd );
      return 0;
   }

   close( fd );
   STACK_PUSH( stack, make_atom_directly_from_string( data, st.st_size + 1 ));

   return 0;
}
