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

#include "runtime.h"

int serv_fd;

void sigchld_handler( int signo )
{
   while( waitpid( -1, NULL, WNOHANG ) > 0 )
      ;
}

/*
 * Allocation.
 */

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

   if ( size == 0 )
      return NULL;

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

   return ptr;
}

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

   ptr = ( char *)memory( len + 1 );

   for( src = str, dst = ptr, i = len; i; --i )
      *dst++ = *src++;

   *dst = '\0';

   return ptr;
}

/*
 * Tables.
 */

struct hash_elt **make_table()
{
   struct hash_elt **table, **ptr;
   int i;

   table = memory( sizeof( struct hash_elt * ) * HASH_SIZE );

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

   return table;
}

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

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

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

   ptr2 = hash[ key ];

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

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

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

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

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

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

   ptr = hash[ key ];

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

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

   return empty_string_atom;
}

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

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

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

   ptr = hash[ key ];
   ptr2 = NULL;

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

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

   if ( ptr == NULL )
      return;

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

   free( ptr );
}

/*
 * Stacks.
 */

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

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

   return a;
}

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

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

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

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

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

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

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

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

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

      return ptr;
   }

   return NULL;
}

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

void stack_clear( struct stack *s )
{
   s->free += s->used;
   s->top = s->values;
   s->used = 0;
}

/*
 * Strings.
 */

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

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

   s = ( struct string *)memory( sizeof( struct string ));
   s->str = ( char *)memory( stack_inc );
   *s->str = '\0';

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

   s->free = stack_inc - 1;
   s->used = 0;
   s->top = s->str;

   return s;
}

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

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

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

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

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

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

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

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

   s->str[ 0 ] = c;

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

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

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

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

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

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

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

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

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

   *ptr = '\0';

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

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

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

void string_assign( struct string *s, char *c, int len )
{
   string_clear( s );
   while ( len-- )
      string_append( s, *c++ );
}

/*
 * Atoms.
 */

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

   switch( type( atom->flags ))
   {
      case ATOM_STRING:
         break;

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

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

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

      case ATOM_TABLE:
         free( atom->data.table );
         break;
   }
}

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

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

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

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

   ptr = atoms[ key ];
   ptr2 = NULL;

   do
   {
      if ( ptr->element->syntax == name )
         break;

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

   if ( ptr == NULL )
      return;

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

   free( ptr );
}

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

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

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

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

      atoms[ key ] = memory( sizeof( struct hash_elt ));
      atoms[ key ]->element = atom;
      atoms[ key ]->next = NULL;

      return atom;
   }

   ptr2 = atoms[ key ];

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

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

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

         if ( idx < 0 )
            return atom;
      }

      ptr2 = ptr;
   }

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

   atom = make_atom();
   atom->syntax = str_dup( name, len );
   atom->flags = len << 8;

   ptr->element = atom;

   return atom;
}

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

   if ( atom_pool_free == 0 )
   {
      stack_push( atom_pool_stack, ( void *)atom_pool );
      atom_pool = ( struct atom *)memory( sizeof( struct atom ) * POOL_INC );
      atom_pool_ptr = atom_pool;
      bzero( atom_pool, POOL_INC );
      atom_pool_free = POOL_INC;
   }

   --atom_pool_free;

   bzero( atom_pool_ptr, sizeof( struct atom ) );

   return atom_pool_ptr++;
}

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

   ptr = hash;

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

      ptr2 = *ptr;

      do
      {
         ptr3 = ptr2->next;
         free( ptr2 );
         ptr2 = ptr3;
      }
      while( ptr2 != NULL );

      ++ptr;
   }
}

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

   i = atom_pool_stack->used;

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

      for( j = 0; j < POOL_INC; ++j, ++top )
         if ( numberp( top ) == 0 && top->flags )
            free_data( top );
   }

   for( top = atom_pool; top < atom_pool_ptr; ++top )
      if ( numberp( top ) == 0 && top->flags )
         free_data( top );
}

void free_atoms()
{
   struct atom *ptr;

   free_atom_data();
   free( atom_pool );

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

   stack_free( atom_pool_stack );
}

struct atom *make_atom_from_table( struct hash_elt **table )
{
   static int counter = 0;
   char buffer[ 32 ];
   int len;
   struct atom *atom;

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

   atom = make_atom();
   atom->syntax = str_dup( buffer, len );
   atom->flags = len << 8;
   atom->flags |= ATOM_TABLE;

   atom->data.table = table;

   return atom;
}

struct atom *make_atom_from_stack( struct stack *s )
{
   static int counter = 0;
   char buffer[ 32 ];
   int len;
   struct atom *atom;

   snprintf( buffer, sizeof( buffer ), "<STACK#%d>", counter++ );
   len = strlen( buffer );

   atom = make_atom();
   atom->syntax = str_dup( buffer, len );
   atom->flags = len << 8;
   atom->flags |= ATOM_STACK;

   atom->data.stack = s;

   return atom;
}

struct atom *make_atom_from_record( struct atom **a )
{
   static int counter = 0;
   char buffer[ 32 ];
   int len;
   struct atom *atom;

   snprintf( buffer, sizeof( buffer ), "<RECORD#%d>", counter++ );
   len = strlen( buffer );

   atom = make_atom();
   atom->syntax = str_dup( buffer, len );
   atom->flags = len << 8;
   atom->flags |= ATOM_RECORD;

   atom->data.record = a;

   return atom;
}

struct atom *make_atom_from_string( char *s, int len, int duplicate )
{
   struct atom *entry;

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

   entry = get_atom( s, len, duplicate );
   entry->flags |= ATOM_STRING;

   return entry;
}

struct atom *make_atom_from_regexp( regex_t *regexp )
{
   static int counter = 0;
   char buffer[ 32 ];
   int len;
   struct atom *atom;

   snprintf( buffer, sizeof( buffer ), "<REGEXP#%d>", counter++ );
   len = strlen( buffer );

   atom = make_atom();
   atom->syntax = str_dup( buffer, len );
   atom->flags = len << 8;
   atom->flags |= ATOM_REGEXP;

   atom->data.regexp = regexp;

   return atom;
}

/*
 * Closures.
 */

void make_closure( void ( *func )(), int args )
{
   struct atom *atom;

   atom = make_atom();
   atom->syntax = str_dup( "<CLOSURE>", 9 );
   atom->flags = 9 << 8;
   atom->flags |= ATOM_CLOSURE;

   atom->data.closure = memory( sizeof( struct atom * ) * ( args + 2 ));
   atom->data.closure[ 0 ] = ( struct atom *)func;
   atom->data.closure[ args + 1 ] = NULL;

   while( args )
      atom->data.closure[ args-- ] = stack_pop( stack );

   stack_push( stack, atom );
}

/*
 * Startup
 */

void initialize( char **argv, int argc )
{
   signal( SIGCHLD, sigchld_handler );

   srandomdev();
   stack_inc = 12;
   exit_status = 0;

   stack = make_stack();

   globals = memory( sizeof( struct atom * ) * num_globals );

   reclaimed_atoms = make_stack();
   atom_pool_stack = make_stack();

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

   bzero( atoms, sizeof( struct hash_elt * ) * HASH_SIZE );

   working_string = make_string();
   private_string = make_string();
   working_stack = make_stack();

   empty_string_atom = make_atom_from_string( "", 0, 1 );

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

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

   serv_fd = -1;
}

void resume_descriptor( int arg1 )
{
   int fd;

   fd = ( int )stack_pop( descriptors[ arg1 ] );

   switch( arg1 )
   {
      case 0:
         if ( stdin != NULL )
            fclose( stdin );
         break;

      case 1:
         if ( stdout != NULL )
            fclose( stdout );
         break;

      case 2:
         if ( stderr != NULL )
            fclose( stderr );
         break;
   }

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

   close( fd );

   switch( arg1 )
   {
      case 0:
         stdin = fdopen( arg1, "r" );
         break;

      case 1:
         stdout = fdopen( arg1, "w" );
         break;

      case 2:
         stderr = fdopen( arg1, "w" );
         break;
   }

   *stack->top = toptr( 1 );
}

/*
 * Shutdown
 */

void cleanup()
{
   hash_free( atoms );
   free_atoms();

   stack_free( stack );
   stack_free( reclaimed_atoms );

   stack_free( working_stack );
   string_free( working_string );
   string_free( private_string );

   free( globals );

   {
      int i;

      for( i = 0; i < 3; ++i )
         while( descriptors[ i ]->used )
            resume_descriptor( i );
   }
}

/*
 * GC
 */

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

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

   old_stack_inc = stack_inc;
   stack_inc = POOL_INC;

   i = atom_pool_stack->used;

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

      for( j = 0; j < POOL_INC; ++j, ++top )
         if ( numberp( top ) == 0 )
         {
            if ( ismarked( top->flags ) )
               unmark( top->flags );
            else
            {
               if ( type( top->flags ) == ATOM_STRING )
                  remove_atom( top->syntax, length( top->flags ));

               free_data( top );
               bzero( top, sizeof( struct atom ));
               stack_push( reclaimed_atoms, top );
            }
   		}
   }

   for( top = atom_pool; top < atom_pool_ptr; ++top )
   {
      if ( numberp( top ) == 0 )
      {
         if ( ismarked( top->flags ) )
            unmark( top->flags );
         else
         {
            if ( type( top->flags ) == ATOM_STRING )
               remove_atom( top->syntax, length( top->flags ));

            free_data( top );
            bzero( top, sizeof( struct atom ));
            stack_push( reclaimed_atoms, top );
         }
   	}
   }

   stack_inc = old_stack_inc;
}

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

   stk = make_stack();
   ptr2 = table;

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

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

   return stk;
}

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

   stk = make_stack();
   ptr2 = table;

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

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

   return stk;
}

void mark_table( struct atom *atom )
{
   struct stack *values;

   values = get_hash_keys( atom->data.table );

   while( values->used )
      mark_atom( stack_pop( values ) );

   stack_free( values );

   values = get_hash_values( atom->data.table );

   while( values->used )
      mark_atom( stack_pop( values ) );

   stack_free( values );
}

void mark_stack( struct atom *atom )
{
   struct atom **ptr;

   if ( atom->data.stack->used )
      for( ptr = atom->data.stack->values; ptr <= atom->data.stack->top; ++ptr )
         mark_atom( *ptr );
}

void mark_closure( struct atom *closure )
{
   struct atom **ptr;

   for( ptr = &( closure->data.closure[ 1 ] ); *ptr != NULL; ++ptr )
      mark_atom( *ptr );
}

void mark_atom( struct atom *ptr )
{
   if ( numberp( ptr ) )
      return;

   mark( ptr->flags );

   switch( type( ptr->flags ) )
   {
      case ATOM_CLOSURE:
         mark_closure( ptr );
         break;

      case ATOM_STACK:
         mark_stack( ptr );
         break;

      case ATOM_TABLE:
         mark_table( ptr );
         break;
   }
}

void mark_atoms()
{
   struct atom **ptr;
   int i;

   mark( empty_string_atom->flags );

   if ( stack->used )
      for( ptr = stack->values; ptr <= stack->top; ++ptr )
         mark_atom( *ptr );

   for( ptr = globals, i = 0; i < num_globals; ++ptr, ++i )
      if ( *ptr != NULL )
         mark_atom( *ptr );
}

void collect_garbage()
{
   mark_atoms();
   sweep_atoms();
}

/*
 * Trampoline.
 */

int main( int argc, char **argv )
{
   int gc = GC_FREQUENCY;

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

   next = FUNCTION_0;

   while( next != NULL )
   {
      next();

      if ( --gc == 0 )
      {
         collect_garbage();
         gc = GC_FREQUENCY;
      }
   }

   return exit_status;
}

/*
 * The non-macro intrinsics begin here and continue to the end of the file.
 */

void readchars()
{
   char *buffer;
   int result;

   buffer = memory( number( *stack->top ) );

   if (( result = fread( buffer, number( *stack->top ), 1, stdin )) <= 0 )
   {
      free( buffer );

      if ( feof( stdin ) )
      {
         *stack->top = toptr( 0 );
         return;
      }
      else
      {
         fprintf( stderr, "read: fread: %s.\n", strerror( errno ));
         exit( 1 );
      }
   }

   *stack->top = make_atom_from_string( buffer, result, 0 );
}

void join( int stk )
{
   struct atom **atom;
   char *sep, *ptr;
   int len, i;

   stack_clear( working_stack );

   if ( stk )
   {
      for( i = ( *stack->top )->data.stack->used - 1; i >= 0; --i )
         stack_push( working_stack, ( *stack->top )->data.stack->values[ i ] );
      stack_pop( stack );
   }
   else
   {
      i = number( stack_pop( stack ));

      while( i-- )
         stack_push( working_stack, stack_pop( stack ));
   }

   sep = ( *working_stack->top )->syntax;
   len = length( ( *working_stack->top )->flags );

   string_clear( working_string );

   for( atom = working_stack->top - 1; atom > working_stack->values; --atom )
   {
      i = length( ( *atom )->flags );
      ptr = ( *atom )->syntax;

      while( i-- )
         string_append( working_string, *ptr++ );

      i = len;
      ptr = sep;

      while( i-- )
         string_append( working_string, *ptr++ );
   }

   i = length( ( *atom )->flags );
   ptr = ( *atom )->syntax;

   while( i-- )
      string_append( working_string, *ptr++ );

   stack_push( stack, make_atom_from_string( working_string->str, working_string->used, 1 ));
}

void split()
{
   char *input, *next, *delim;
   struct atom *atom;
   struct stack *output;
   int limit;

   limit = number( stack_pop( stack ));

   atom = stack_pop( stack );
   string_assign( working_string, atom->syntax, length( atom->flags ));

   delim = ( *stack->top )->syntax;
   output = make_stack();

   input = working_string->str;

   if ( limit )
   {
      while( --limit && input != NULL )
      {
         next = strsep( &input, delim );
         stack_push( output, make_atom_from_string( next, -1 , 1));
      }

      if ( input != NULL )
         stack_push( output, make_atom_from_string( input, -1 , 1 ));

      if ( input == NULL && output->used == 0 )
         stack_push( output, atom );
   }

   *stack->top = make_atom_from_stack( output );
}

int compare_strings( const void *a, const void *b )
{
   return strcmp( ( *( struct atom **)a )->syntax, ( *( struct atom **)b )->syntax );
}

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

void exec( int stk )
{
   struct atom **ptr;

   stack_clear( working_stack );

   if ( stk )
   {
      struct stack *stk;

      stk = ( stack_pop( stack ) )->data.stack;

      for( ptr = stk->values; ptr <= stk->top; ++ptr )
         stack_push( working_stack, ( struct atom *)( *ptr )->syntax );
   }
   else
   {
      int args;

      args = number( stack_pop( stack ));

      for( ptr = ( stack->top - args ) + 1; ptr <= stack->top; ++ptr )
         stack_push( working_stack, ( struct atom *)( *ptr )->syntax );
   }

   stack_push( working_stack, NULL );
   execvp( ( char *)working_stack->values[ 0 ], ( char **)&working_stack->values[ 0 ] );
}

void shift()
{
   int i, top;
   struct atom *result;

   if ( ( *stack->top )->data.stack->used )
   {
      result = ( *stack->top )->data.stack->values[ 0 ];
      top = ( *stack->top )->data.stack->used - 1;

      for( i = 0; i < top; ++i )
         ( *stack->top )->data.stack->values[ i ] =
            ( *stack->top )->data.stack->values[ i + 1 ];

      if ( --( *stack->top )->data.stack->used )
         --( *stack->top )->data.stack->top;
      ++( *stack->top )->data.stack->free;

      *stack->top = result;
   }
   else
      *stack->top = empty_string_atom;
}

void unshift()
{
   struct atom *new;
   int i;

   new = stack_pop( stack );

   stack_push( ( *stack->top )->data.stack, NULL );

   for( i = ( *stack->top )->data.stack->used - 1; i; --i )
      ( *stack->top )->data.stack->values[ i ] =
         ( *stack->top )->data.stack->values[ i - 1 ];

   ( *stack->top )->data.stack->values[ 0 ] = new;
}

void regexp_comp()
{
   char *ptr, *tmp;
   int len, escape = 0;

   ptr = ( *stack->top )->syntax;
   len = length( ( *stack->top )->flags );
   string_clear( working_string );

   for( ; len; --len )
   {
      if ( *ptr == '\\' )
      {
         escape ^= 1;

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

         ++ptr;
         continue;
      }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      ++ptr;
      escape = 0;
   }

   {
      int result;
      regex_t *regexp;

      regexp = memory( sizeof( regex_t ));
      regexp->re_endp = &working_string->str[ working_string->used ];
      result = regcomp( regexp, working_string->str, REG_EXTENDED | REG_PEND );

      if ( result )
      {
         char err[ 80 ];

         regerror( result, regexp, err, sizeof( err ));
         free( regexp );

         *stack->top = make_atom_from_string( err, -1, 1 );
      }
      else
         *stack->top = make_atom_from_regexp( regexp );
   }
}

struct stack *apply_regexp( regex_t *regexp, char *the_string, int len, int show_offset )
{
   struct stack *s;
   regmatch_t matches[ 20 ];
   int result, length, i;

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

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

   if ( result )
   {
      char err[ 80 ];

      if ( result == REG_NOMATCH )
         return NULL;

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

   s = make_stack();

   if ( show_offset )
   {
      stack_push( s, toptr( ( int )matches[ 0 ].rm_so ));
      stack_push( s, toptr( ( int )matches[ 0 ].rm_eo ));

      if ( show_offset == 2 )
         return s;
   }

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

         string_clear( working_string );
         length = matches[ i ].rm_so + matches[ i ].rm_eo - matches[ i ].rm_so;
         frag = &the_string[ matches[ i ].rm_so ];

         for( j = matches[ i ].rm_so; j < length; ++j )
            string_append( working_string, *frag++ );

         stack_push( s, make_atom_from_string( working_string->str, working_string->used, 1 ));
      }
      else
         stack_push( s, empty_string_atom );
   }

   return s;
}

void regexp_match( int substrings )
{
   struct atom *atom;
   struct stack *result;

   atom = stack_pop( stack );

   if (( result = apply_regexp( ( *stack->top )->data.regexp, atom->syntax,
                                length( atom->flags ),
                                ( substrings ? 0 : 2 ))) == NULL )
      *stack->top = toptr( 0 );
   else
      *stack->top = make_atom_from_stack( result );
}

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

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

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

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

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

   return change_case;
}

void regexp_substitute()
{
   char *the_string, *replacement, *tmp1, *tmp2, *tmp3, *tmp4, *old_tmp4, *subs[ 11 ], *ptr;
   struct atom *atom, **r;
   struct stack *results;
   int escape, repeat, count, len2, len3, change_case, first, begin, end, i;
   regex_t *rx;

   repeat = number( stack_pop( stack ));

   atom = stack_pop( stack );
   the_string = atom->syntax;
   len3 = length( atom->flags );

   atom = stack_pop( stack );
   replacement = atom->syntax;
   len2 = length( atom->flags );

   rx = ( *stack->top )->data.regexp;

   tmp2 = replacement;
   tmp3 = the_string;
   tmp4 = tmp3;

   change_case = 0;

   count = 0;
   old_tmp4 = NULL;

   first = 1;
   string_clear( private_string );

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

      first = 0;

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

      old_tmp4 = tmp4;

      results = apply_regexp( rx, tmp4, len3 - ( tmp4 - tmp3 ), 1 );

      if ( results == NULL )
         break;

      begin = number( results->values[ 0 ] );
      end = number( results->values[ 1 ] );
      i = 0;

      for( r= &results->values[ 2 ] ; r <= results->top; ++r )
      {
         subs[ i++ ] = ( *r )->syntax;

         if ( i > 10 )
            break;
      }

      stack_free( results );

      ptr = tmp4;

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

      escape = 0;

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

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

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

            escape = 0;

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

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

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

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

               case 'b':
                  string_append( private_string, ' ' );
                  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;

               default:
                  string_append( private_string, '\\' );
                  continue;
            }
         }

         change_case = add_char( ptr, change_case );
      }

      tmp4 = &tmp4[ end ];

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

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

   *stack->top = make_atom_from_string( private_string->str, private_string->used, 1 );

   return;
}

void redirect()
{
   int flags, arg1, arg3, fd;
   struct atom *arg2;
   mode_t mode;

   arg3 = number( stack_pop( stack ));
   arg2 = stack_pop( stack );
   arg1 = number( *stack->top );

   flags = 0;

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

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

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

AGAIN:
   if (( fd = open( arg2->syntax, flags, mode )) < 0 )
   {
      if ( errno == EINTR )
         goto AGAIN;

      if ( errno == ENOENT )
      {
         *stack->top = toptr( -1 );
         return;
      }
      else if ( errno == EACCES )
      {
         *stack->top = toptr( -2 );
         return;
      }
      else if ( errno == EBUSY || errno == EAGAIN )
      {
         *stack->top = toptr( -3 );
         return;
      }

      *stack->top = make_atom_from_string( strerror( errno ), -1, 1 );
      return;
   }

   if ( arg1 && arg3 == 0 )
      if ( ftruncate( fd, 0 ))
      {
         close( fd );

         if ( errno == EBUSY )
         {
            *stack->top = toptr( -3 );
            return;
         }

         *stack->top = make_atom_from_string( strerror( errno ), -1, 1 );
         return;
      }

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

   switch( arg1 )
   {
      case 0:
         fclose( stdin );
         break;

      case 1:
         fclose( stdout );
         break;

      case 2:
         fclose( stderr );
         break;
   }

   stack_push( descriptors[ arg1 ], ( struct atom *)flags );

   if ( dup2( fd, arg1 ) < 0 )
   {
      close( fd );
      resume_descriptor( arg1 );
      *stack->top = make_atom_from_string( strerror( errno ), -1, 1 );
      return;
   }

   close( fd );

   {
      FILE *fp = NULL;

      switch( arg1 )
      {
         case 0:
            stdin = fp = fdopen( arg1, "r" );
            break;

         case 1:
            stdout = fp = fdopen( arg1, ( arg3 ? "a" : "w" ));
            break;

         case 2:
            stderr = fp = fdopen( arg1, ( arg3 ? "a" : "w" ));
            break;
      }

      if ( fp == NULL )
      {
         resume_descriptor( arg1 );
         *stack->top = make_atom_from_string( strerror( errno ), -1, 1 );
         return;
      }
   }

   *stack->top = toptr( 1 );
}

void pipe_open( char *syntax, char *task, int wrt )
{
   int fd[ 2 ], pid, flag;
   FILE *fp = NULL;
   char *args[ 4 ];

   if ( pipe( &fd[ 0 ] ) < 0 )
   {
      *stack->top = make_atom_from_string( strerror( errno ), -1, 1 );
      exit( 1 );
   }

   switch(( pid = fork() ))
   {
      case -1:
         close( fd[ 0 ] );
         close( fd[ 1 ] );
         *stack->top = make_atom_from_string( strerror( errno ), -1, 1 );
         exit( 1 );

      case 0:
         if (( dup2( fd[ 1 ], !wrt )) < 0 )
         {
            fprintf( stderr, "%s (child): dup2: %s.\n", syntax, strerror( errno ));
            _exit( 1 );
         }

         close( fd[ 0 ] );
         close( fd[ 1 ] );

         args[ 0 ] = "/bin/sh";
         args[ 1 ] = "-c";
         args[ 2 ] = task;
         args[ 3 ] = NULL;

         execv( args[ 0 ], args );
         fprintf( stderr, "%s: (child): execv: %s.\n", syntax, strerror( errno ));
         _exit( 1 );

      default:
         close( fd[ 1 ] );

         if (( flag = dup( wrt )) < 0 )
         {
            close( fd[ 0 ] );
            *stack->top = make_atom_from_string( strerror( errno ), -1, 1 );
            return;
         }

         stack_push( descriptors[ wrt ], ( void *)flag );

         switch( wrt )
         {
            case 0:
               fclose( stdin );
               stdin = NULL;
               break;

            case 1:
               fclose( stdout );
               stdout = NULL;
               break;

            case 2:
               fclose( stderr );
               stderr = NULL;
               break;
         }

         if ( dup2( fd[ 0 ], wrt ) < 0 )
         {
            close( fd[ 0 ] );
            resume_descriptor( wrt );
            *stack->top = make_atom_from_string( strerror( errno ), -1, 1 );
            return;
         }

         close( fd[ 0 ] );

         switch( wrt )
         {
            case 0:
               stdin = fp = fdopen( wrt, "r" );
               break;

            case 1:
               stdout = fp = fdopen( wrt, "w" );
               break;

            case 2:
               stderr = fp = fdopen( wrt, "w" );
               break;
          }

         if ( fp == NULL )
         {
            resume_descriptor( wrt );
            *stack->top = make_atom_from_string( strerror( errno ), -1, 1 );
            return;
         }

   }

   *stack->top = toptr( 1 );
}

void directory()
{
   DIR *dir;
   struct dirent *dp;
   struct stack *stk;

   if (( dir = opendir( ( *stack->top )->syntax )) == NULL )
   {
      *stack->top = make_atom_from_string( strerror( errno ), -1, 1 );
      return;
   }

   readdir( dir );

   stk = make_stack();

   while(( dp = readdir( dir )) != NULL )
      stack_push( stk, make_atom_from_string( dp->d_name, dp->d_namlen, 1 ));

   *stack->top = make_atom_from_stack( stk );

   closedir( dir );
}

void file_rename()
{
   struct atom *to;

   to = stack_pop( stack );

   if ( rename( ( *stack->top )->syntax, to->syntax )  < 0 )
      *stack->top = make_atom_from_string( strerror( errno ), -1, 1 );
   else
      *stack->top = toptr( 0 );
}

void file_remove()
{
   if ( remove( ( *stack->top )->syntax ) < 0 )
      *stack->top = make_atom_from_string( strerror( errno ), -1, 1 );
   else
      *stack->top = toptr( 0 );
}

void file_stat()
{
   struct stat st;
   struct group *gp;
   struct passwd *pw;
   struct stack *result;
   char buffer[ 17 ];

   if ( stat( ( *stack->top )->syntax, &st ) < 0 )
   {
      *stack->top = make_atom_from_string( strerror( errno ), -1, 1 );
      return;
   }

   result = make_stack();
   *stack->top = make_atom_from_stack( result );

   pw = getpwuid( st.st_uid );

   if ( pw == NULL )
      stack_push( result, toptr( st.st_uid ) );
   else
      stack_push( result, make_atom_from_string( pw->pw_name, -1, 1 ));

   gp = getgrgid( st.st_gid );

   if ( gp == NULL )
      stack_push( result, toptr( st.st_gid ));
   else
      stack_push( result, make_atom_from_string( gp->gr_name, -1, 1 ));

   snprintf( buffer, sizeof( buffer ), "%016lu", st.st_atime );
   stack_push( result, make_atom_from_string( buffer, -1, 1 ));

   snprintf( buffer, sizeof( buffer ), "%016lu", st.st_mtime );
   stack_push( result, make_atom_from_string( buffer, -1, 1 ));

   snprintf( buffer, sizeof( buffer ), "%016lu", st.st_size );
   stack_push( result, make_atom_from_string( buffer, -1, 1 ));
}

void file_symlink()
{
   struct atom *link;

   link = stack_pop( stack );

   if ( symlink( ( *stack->top )->syntax,
                 link->syntax ) < 0 )
      *stack->top = make_atom_from_string( strerror( errno ), -1, 1 );
   else
      *stack->top = toptr( 0 );
}

void expand_tabs()
{
   struct atom *arg2;
   int len, i, offset, tabstop;
   char *ptr;

   arg2 = stack_pop( stack );
   ptr = arg2->syntax;
   len = length( arg2->flags );

   tabstop = number( *stack->top );
   offset = 0;

   string_clear( working_string );

   for( i = 0; i < len; ++i )
   {
      if ( *ptr == '\t' )
      {
         int spaces;

         spaces = tabstop - ( i + offset ) % tabstop;
         offset += spaces - 1;

         while( spaces-- )
            string_append( working_string, ' ' );
      }
      else
         string_append( working_string, *ptr );

      ++ptr;
   }

   *stack->top = make_atom_from_string( working_string->str, working_string->used, 1 );
}

void substack()
{
   struct atom *stk;
   struct stack *new;
   int from, to, i;

   to = number( stack_pop( stack ) );
   from = number( stack_pop( stack ));
   stk = stack_pop( stack );

   new = make_stack();

   for( i = from; i <= to; ++i )
      stack_push( new, stk->data.stack->values[ i ] );

   stack_push( stack, make_atom_from_stack( new ));
}

void append_stacks()
{
   int total, i, j;
   struct stack *new;
   struct atom *stk;

   total = number( stack_pop( stack ));
   new = make_stack();

   for( j = stack->used - total; j < stack->used; ++j )
   {
      stk = stack->values[ j ];

      for( i = 0; i < stk->data.stack->used; ++i )
         stack_push( new, stk->data.stack->values[ i ] );
   }

   while( total-- )
      stack_pop( stack );

   stack_push( stack, make_atom_from_stack( new ));
}