/* liblmin.c - minimal embeddable LISP interpreter
**
** Inspired and guided by Robert A. van Engelen's tinylisp.
**
** Copyright (C) 2026 by Jef Poskanzer <jef@mail.acme.com>.
** All rights reserved.
**
** You may use this software however you like as long as you keep my
** name on it and don't sue me.
**
** For commentary on this license please see http://acme.com/license.html
*/

#include <sys/types.h>
#include <sys/time.h>
#include <sys/resource.h>
#include <stdlib.h>
#include <unistd.h>
#include <stdbool.h>
#include <stdarg.h>
#include <string.h>
#include <math.h>
#include <ctype.h>
#include <stdio.h>
#include <sysexits.h>
#include <errno.h>
#include <regex.h>

#include "liblmin.h"
#include "leakfinder.h"


/* Define this to run consistency checks on the atom and cell pools. */
#undef CHECKS

#define EOL (-1)
#define max(a, b) ( (a) > (b) ? (a) : (b) )
#define min(a, b) ( (a) < (b) ? (a) : (b) )
typedef bool (*pred_fp)( lmin_cellidx c );

/* Forward prototypes */
static lmin_cellidx acons( lmin_cellidx key, lmin_cellidx datum, lmin_cellidx alist );
static lmin_cellidx invoke_primitive( lmin_cellidx f, lmin_cellidx args, lmin_cellidx e );
static lmin_cellidx invoke_closure( lmin_cellidx f, lmin_cellidx args, lmin_cellidx e );
static lmin_cellidx invoke_macro( lmin_cellidx f, lmin_cellidx args, lmin_cellidx callenv );
static lmin_cellidx substitute( lmin_cellidx vars, lmin_cellidx vals, lmin_cellidx body );
static void celldump( lmin_cellidx c );
static void read_init( void );
static void read_term( void );


/* Atoms
**
** Atoms are unique symbols represented by ints. The process of turning
** a symbol into an int is called interning. The same symbol will always
** have the same int, which means that atoms can be compared by comparing
** their ints.
**
** Atoms are stored on two singly-linked lists, one for those in
** use and the other for those that are free. Atoms that go out
** of use may be moved from the in-use list to the free list by
** garbage collection.
**
** As an optimization, the atoms are not stored as separately
** allocated objects but instead are all in one big array.
** If the array fills up, it can be expanded.
**
** Another optimization is that there's space in the atom struct
** to store the string value, if it's short enough. If it's too
** long then a pointer to a malloced string is stored instead.
**
** Interning a symbol requires a linear search of the entire in-use
** list, which could be an expensive operation if there are a lot
** of atoms in use. Using another data structure could improve this.
*/

#define ATOMS_INITIAL_SIZE 1000
#define ATOM_MAX_INTERNAL_STR 11

typedef struct {
    char internal_str[ATOM_MAX_INTERNAL_STR];
    char* external_str;
    lmin_atomidx next_idx;
    unsigned char flags;
    } atom;

static atom* atoms;
static size_t atoms_size;
static lmin_atomidx atoms_inuse_list;
static lmin_atomidx atoms_free_list;

/* Atom flags. */
#define atom_flag_marked 0x1
#define atom_marked_is(a) ((atoms[a].flags & atom_flag_marked)?true:false)
#define atom_marked_set(a) (atoms[a].flags |= atom_flag_marked)
#define atom_marked_clear(a) (atoms[a].flags &= (unsigned char) ~atom_flag_marked)

static void atoms_add_free( lmin_atomidx start_idx, lmin_atomidx end_idx )
    {
    lmin_atomidx a;

    /* Put everything from start_idx through end_idx-1 onto the free list. */
    for ( a = start_idx; a < end_idx; ++a )
	{
	atoms[a].next_idx = atoms_free_list;
	atoms_free_list = a;
	}
    }

static void atoms_init( void )
    {
    atoms_size = ATOMS_INITIAL_SIZE;
    atoms = (atom*) MALLOC( sizeof(atom) * atoms_size );
    if ( atoms == (atom*) 0 )
	{
	fprintf( stderr, "liblmin: out of memory\n" );
	exit( EX_SOFTWARE );
	}
    atoms_inuse_list = atoms_free_list = EOL;
    atoms_add_free( 0, (lmin_atomidx) atoms_size );
    }

static void atoms_term( void )
    {
    lmin_atomidx a;

    a = atoms_inuse_list;
    while ( a != EOL )
	{
	if ( atoms[a].external_str != (char*) 0 )
	    FREE( (void*) atoms[a].external_str );
	a = atoms[a].next_idx;
	}
    FREE( (void*) atoms );
    }

static const char* atom_str_get( lmin_atomidx a )
    {
    if ( atoms[a].external_str != (char*) 0 )
	return atoms[a].external_str;
    else
	return (const char*) &atoms[a].internal_str;
    }

static lmin_atomidx atom_intern( const char* str )
    {
    lmin_atomidx a;

    /* Search all in-use atoms to see if it's already there. */
    a = atoms_inuse_list;
    while ( a != EOL )
	{
	if ( strcmp( str, atom_str_get( a ) ) == 0 )
	    return a;			/* got it */
	a = atoms[a].next_idx;
	}

    /* Not found, need to add it. Is there room? */
    if ( atoms_free_list == EOL )
	{
	/* Expand. */
	size_t new_atoms_size = atoms_size * 2;
	atoms = (atom*) REALLOC( (void*) atoms, sizeof(atom) * new_atoms_size );
	if ( atoms == (atom*) 0 )
	    {
	    fprintf( stderr, "liblmin: out of memory\n" );
	    exit( EX_SOFTWARE );
	    }
	atoms_add_free( (lmin_atomidx) atoms_size, (lmin_atomidx) new_atoms_size );
	atoms_size = new_atoms_size;
	}

    /* Move an entry from the free list to the in-use list. */
    a = atoms_free_list;
    atoms_free_list = atoms[a].next_idx;
    atoms[a].next_idx = atoms_inuse_list;
    atoms_inuse_list = a;

    /* Fill in the new entry. */
    if ( strlen( str ) < ATOM_MAX_INTERNAL_STR )
	{
	strcpy( atoms[a].internal_str, str );
	atoms[a].external_str = (char*) 0;
	}
    else
	{
	atoms[a].external_str = STRDUP( str );
	if ( atoms[a].external_str == (char*) 0 )
	    {
	    fprintf( stderr, "liblmin: out of memory\n" );
	    exit( EX_SOFTWARE );
	    }
	}

    return a;
    }

#ifdef CHECKS
static void atoms_check( void )
    {
    int num_inuse = 0, num_free = 0;
    lmin_atomidx a;

    a = atoms_inuse_list;
    while ( a != EOL )
	{
	++num_inuse;
	a = atoms[a].next_idx;
	}
    a = atoms_free_list;
    while ( a != EOL )
	{
	++num_free;
	a = atoms[a].next_idx;
	}
    if ( num_inuse + num_free != atoms_size )
	{
	fprintf( stderr, "liblmin: atoms table is inconsistent - num_inuse=%d num_free=%d atoms_size=%ld\n", num_inuse, num_free, atoms_size );
	exit( EX_SOFTWARE );
	}
    }
#endif /* CHECKS */

static void atoms_unmark_all( void )
    {
    lmin_atomidx a;

    a = atoms_inuse_list;
    while ( a != EOL )
	{
	atom_marked_clear( a );
	a = atoms[a].next_idx;
	}
    }

static int atoms_del_unmarked( void )
    {
    lmin_atomidx* prev_nextP;
    lmin_atomidx a, n;
    int count = 0;

    prev_nextP = &atoms_inuse_list;
    a = atoms_inuse_list;
    while ( a != EOL )
	{
	if ( ! atom_marked_is( a ) )
	    {
	    n = atoms[a].next_idx;
	    *prev_nextP = n;
	    if ( atoms[a].external_str != (char*) 0 )
		{
		FREE( (void*) atoms[a].external_str );
		atoms[a].external_str = (char*) 0;
		}
	    atoms[a].next_idx = atoms_free_list;
	    atoms_free_list = a;
	    a = n;
	    ++count;
	    }
	else
	    {
	    prev_nextP = &atoms[a].next_idx;
	    a = atoms[a].next_idx;
	    }
	}
    return count;
    }

/* Cells
**
** Cells are the basic data structure in LISP. Originally there were only
** two kinds of cells: atom or cons. Later LISPs added more kinds.
**
** The cell data structure is an enum-tagged union.
**
** As with atoms, cells are stored in one big array threaded by two
** linked lists.
**
** The NUM type is worth a little elaboration. Numbers are stored as
** both long and double, plus a flag saying if the long version is valid.
** If the long version is valid then math operations are performed
** on both versions in parallel. Operations that can give non-long
** results clear the flag, leaving only the double version from then on.
*/

#define CELLS_INITIAL_SIZE 1000

typedef struct {
    lmin_celltype typ;
    unsigned char flags;
    union {
	/* NIL     */ /* nothing */
	/* ATOM    */ struct { lmin_atomidx idx; } atom;
	/* CONS    */ struct { lmin_cellidx ar, dr; } cns;
	/* PRIM    */ struct { lmin_prim_fp fp; lmin_cellidx vars; } prim;
	/* CLOSURE */ struct { lmin_cellidx vars, body, defenv; } closure;
	/* MACRO   */ struct { lmin_cellidx vars, body; } macro;
	/* NUM     */ struct { long in; double fl; } num;
	/* CHR     */ struct { char ch; } chr;
	/* STR     */ struct { char* s; size_t len; } str;
	/* STREAM  */ struct { FILE* fp; } stream;
	/* VECTOR  */ struct { lmin_cellidx* v; size_t maxlen, curlen; lmin_cellidx fill; } vec;
	/* DATA    */ struct { void* ptr; lmin_freefp freefp; } data;
	/* ERREX   */ struct { lmin_cellidx payload, callstack; } errex;
	} u;
    lmin_cellidx next_idx;
    } cell;

static cell* cells;
static size_t cells_size;
static lmin_cellidx cells_inuse_list;
static lmin_cellidx cells_free_list;

/* Cell flags. */
#define cell_flag_permanent 0x1
#define cell_flag_marked 0x2
#define cell_flag_special 0x10
#define cell_flag_integer 0x20
#define cell_permanent_is(c) ((cells[c].flags & cell_flag_permanent)?true:false)
#define cell_permanent_set(c) (cells[c].flags |= cell_flag_permanent)
#define cell_permanent_clear(c) (cells[c].flags &= (unsigned char) ~cell_flag_permanent)
#define cell_marked_is(c) ((cells[c].flags & cell_flag_marked)?true:false)
#define cell_marked_set(c) (cells[c].flags |= cell_flag_marked)
#define cell_marked_clear(c) (cells[c].flags &= (unsigned char) ~cell_flag_marked)
#define cell_special_is(c) ((cells[c].flags & cell_flag_special)?true:false)
#define cell_special_set(c) (cells[c].flags |= cell_flag_special)
#define cell_special_clear(c) (cells[c].flags &= (unsigned char) ~cell_flag_special)
#define cell_integer_is(c) ((cells[c].flags & cell_flag_integer)?true:false)
#define cell_integer_set(c) (cells[c].flags |= cell_flag_integer)
#define cell_integer_clear(c) (cells[c].flags &= (unsigned char) ~cell_flag_integer)

lmin_cellidx lmin_nil, lmin_t, lmin_err_incomplete, lmin_err_eof;
lmin_cellidx lmin_stdin, lmin_stdout, lmin_stderr;
static lmin_cellidx nil, t;
static lmin_cellidx env;		/* global environment */

/* A few defines to make the code less verbose. Note that this means we
** can't use these names as variables or struct members.
*/
#define car(c) (lmin_cons_car_get(c))
#define cdr(c) (lmin_cons_cdr_get(c))
#define cons(ar,dr) (lmin_cons_make(ar,dr))
#define not(c) (lmin_nil_is(c))
#define ct(c) (cells[c].typ)

static void cells_add_free( lmin_cellidx start_idx, lmin_cellidx end_idx )
    {
    lmin_cellidx c;

    /* Put everything from start_idx through end_idx-1 onto the free list. */
    for ( c = start_idx; c < end_idx; ++c )
	{
	cells[c].next_idx = cells_free_list;
	cells_free_list = c;
	}
    }

static void cells_init( void )
    {
    cells_size = CELLS_INITIAL_SIZE;
    cells = (cell*) MALLOC( sizeof(cell) * cells_size );
    if ( cells == (cell*) 0 )
	{
	fprintf( stderr, "liblmin: out of memory\n" );
	exit( EX_SOFTWARE );
	}
    cells_inuse_list = cells_free_list = EOL;
    cells_add_free( 0, (lmin_cellidx) cells_size );
    }

static void cells_term( void )
    {
    lmin_cellidx c;

    c = cells_inuse_list;
    while ( c != EOL )
	{
	if ( lmin_str_is( c ) )
	    FREE( (void*) lmin_str_get( c ) );
	else if ( lmin_stream_is( c ) )
	    {
	    FILE* fp = lmin_stream_get( c );
	    if ( fp != (FILE*) 0 && fp != stdin && fp != stdout && fp != stderr )
		fclose( fp );
	    }
	else if ( lmin_vector_is( c ) )
	    FREE( (void*) lmin_vector_getvec( c ) );
	else if ( lmin_data_is( c ) )
	    {
	    void* ptr = lmin_data_ptr_get( c );
	    lmin_freefp freefp = lmin_data_freefp_get( c );
	    if ( ptr != (void*) 0 && freefp != (lmin_freefp) 0 )
		(*freefp)( ptr );
	    }
	c = cells[c].next_idx;
	}
    FREE( (void*) cells );
    }

#ifdef CHECKS
static void cells_check( void )
    {
    int num_inuse = 0, num_free = 0;
    lmin_cellidx c;

    c = cells_inuse_list;
    while ( c != EOL )
	{
	++num_inuse;
	c = cells[c].next_idx;
	}
    c = cells_free_list;
    while ( c != EOL )
	{
	++num_free;
	c = cells[c].next_idx;
	}
    if ( num_inuse + num_free != cells_size )
	{
	fprintf( stderr, "liblmin: cells table is inconsistent - num_inuse=%d num_free=%d cells_size=%ld\n", num_inuse, num_free, cells_size );
	exit( EX_SOFTWARE );
	}
    }
#endif /* CHECKS */

static lmin_cellidx cell_make( lmin_celltype typ )
    {
    lmin_cellidx c;

    /* Is there room? */
    if ( cells_free_list == EOL )
	{
	/* Expand. */
	size_t new_cells_size = cells_size * 2;
	cells = (cell*) REALLOC( (void*) cells, sizeof(cell) * new_cells_size );
	if ( cells == (cell*) 0 )
	    {
	    fprintf( stderr, "liblmin: out of memory\n" );
	    exit( EX_SOFTWARE );
	    }
	cells_add_free( (lmin_cellidx) cells_size, (lmin_cellidx) new_cells_size );
	cells_size = new_cells_size;
	}

    /* Move an entry from the free list to the in-use list. */
    c = cells_free_list;
    cells_free_list = cells[c].next_idx;
    cells[c].next_idx = cells_inuse_list;
    cells_inuse_list = c;

    /* Fill in the new entry. */
    cells[c].typ = typ;
    cells[c].flags = 0;

    return c;
    }

static void cells_unmark_all( void )
    {
    lmin_cellidx c;

    c = cells_inuse_list;
    while ( c != EOL )
	{
	cell_marked_clear( c );
	c = cells[c].next_idx;
	}
    }

static int cells_del_unmarked( void )
    {
    lmin_cellidx* prev_nextP;
    lmin_cellidx c, n;
    int count = 0;

    prev_nextP = &cells_inuse_list;
    c = cells_inuse_list;
    while ( c != EOL )
	{
	if ( ! cell_marked_is( c ) )
	    {
	    n = cells[c].next_idx;
	    *prev_nextP = n;
	    if ( lmin_str_is( c ) )
		{
		FREE( (void*) lmin_str_get( c ) );
		cells[c].u.str.s = (char*) 0;
		}
	else if ( lmin_stream_is( c ) )
		{
		FILE* fp = lmin_stream_get( c );
		if ( fp != (FILE*) 0 && fp != stdin && fp != stdout && fp != stderr )
		    fclose( fp );
		cells[c].u.stream.fp = (FILE*) 0;
		}
	    else if ( lmin_vector_is( c ) )
		{
		FREE( (void*) lmin_vector_getvec( c ) );
		cells[c].u.vec.v = (lmin_cellidx*) 0;
		}
	    else if ( lmin_data_is( c ) )
		{
		void* ptr = lmin_data_ptr_get( c );
		lmin_freefp freefp = lmin_data_freefp_get( c );
		if ( ptr != (void*) 0 && freefp != (lmin_freefp) 0 )
		    (*freefp)( ptr );
		cells[c].u.data.ptr = (void*) 0;
		cells[c].u.data.freefp = (lmin_freefp) 0;
		}
	    cells[c].next_idx = cells_free_list;
	    cells_free_list = c;
	    c = n;
	    ++count;
	    }
	else
	    {
	    prev_nextP = &cells[c].next_idx;
	    c = cells[c].next_idx;
	    }
	}
    return count;
    }


/* Type checking
**
** These routines provide a rudimentary type checking facility for both
** LISP closures and C primitives. Argument types are specified by string
** annotations in the formal parameter list, before the parameter name
** they apply to.
**
** A typespec is a string containing:
**   - a type name, one of: atom list function number integer character string
**   - multiple type names separated by vertical bars
**   - a trailing *?+ indicating zero-or-more, zero-or-one, one-or-more
** If the parameter list includes an operator, it must be on the last typespec.
*/

static regex_t typespec_re;

static bool any_is( lmin_cellidx c )
    {
    return t;
    }

static bool list_is( lmin_cellidx c )
    {
    return lmin_nil_is( c ) ? true : lmin_cons_is( c ) ? list_is( cdr( c ) ) : false;
    }

static bool function_is( lmin_cellidx c )
    {
    return lmin_prim_is( c ) || lmin_closure_is( c );
    }

typedef struct {
    const char* name;
    size_t len;
    pred_fp pred;
    } one_type;
static one_type types[] = {
    { "atom", 0, lmin_atom_is },
    { "cons", 0, lmin_cons_is },
    { "list", 0, list_is },
    { "function", 0, function_is },
    { "number", 0, lmin_num_is },
    { "integer", 0, lmin_num_integer_is },
    { "character", 0, lmin_chr_is },
    { "string", 0, lmin_str_is },
    { "stream", 0, lmin_stream_is },
    { "vector", 0, lmin_vector_is },
    { "data", 0, lmin_data_is },
    { "any", 0, any_is },
    };
static const long ntypes = sizeof(types) / sizeof(*types);

static const char* punctuation = "|*?+";
static const char* operators = "*?+";

static void typecheck_init( void )
    {
    int i;
    char types_restr[200];
    char typespec_restr[200];
    char err[100];

    /* Fill in the type name lengths. */
    for ( i = 0; i < ntypes; ++i )
	types[i].len = strlen( types[i].name );

    /* Build the typespec regular expression string from the list of types. */
    strcpy( types_restr, "" );
    for ( i = 0; i < ntypes; ++i )
	{
	if ( i > 0 )
	    strcat( types_restr, "|" );
	strcat( types_restr, types[i].name );
	}
    strcpy( typespec_restr, "^(" );
    strcat( typespec_restr, types_restr );
    strcat( typespec_restr, ")(\\|(" );
    strcat( typespec_restr, types_restr );
    strcat( typespec_restr, "))*[*?+]?$" );

    /* Compile the regular expression. */
    i = regcomp( &typespec_re, typespec_restr, REG_EXTENDED|REG_NOSUB );
    if ( i != 0 )
	{
	regerror( i, &typespec_re, err, sizeof( err ) );
	fprintf( stderr, "regcomp error - %s\n", err );
	exit( EX_SOFTWARE );
	}
    }

static void typecheck_term( void )
    {
    regfree( &typespec_re );
    }

static int find_type( const char* name )
    {
    int i;
    for ( i = 0; i < ntypes; ++i )
	if ( strncmp( name, types[i].name, types[i].len ) == 0 )
	    return i;
    return -1;
    }

/* Check an evaluated argument list for any errors. The first one
** found gets returns, and if there are none then the return is t.
** Usually the second thing done by a C primitive function.
*/
lmin_cellidx lmin_check_errs( lmin_cellidx vals )
    {
    while ( lmin_cons_is( vals ) )
	{
	if ( lmin_errex_is( car( vals ) ) )
	    return car( vals );
	vals = cdr( vals );
	}
    return t;
    }

/* Check that a formal parameters list's typespecs have correct syntax.
** This is similar to check_types except it only does syntax checking,
** while check_types also takes a list of values and checks their types
** against the typespecs in the formals.
**
** This one is intended to be called when a closure or primitive
** is defined, while check_types is called when a closure or
** primitive runs.
*/
static lmin_cellidx check_typespecs( lmin_cellidx vars )
    {
    lmin_cellidx var;
    const char* typespec;
    bool operator = false;

    /* Look through the vars, checking that any typespecs are syntactically
    ** valid and any vars are atoms.
    */
    for ( var = vars; lmin_cons_is( var ); var = cdr( var ) )
	{
	/* Check for a typespec. */
	if ( lmin_str_is( car( var ) ) )
	    {
	    /* Got a typespec - check that it's valid. */
	    typespec = lmin_str_get( car( var ) );
	    if ( regexec( &typespec_re, typespec, 0, 0, 0 ) != 0 )
		return lmin_errex_err_make( "invalid typespec - \"%s\"", typespec );
	    /* If the typespec has an operator at the end, make a note of it. */
	    if ( strlen( typespec ) > 0 )
		{
		if ( strchr( operators, typespec[strlen( typespec ) - 1] ) != (char*) 0 )
		    {
		    if ( operator )
			return lmin_errex_err_make( "typespecs have multiple operators - \"%s\"", lmin_tocstring( vars ) );
		    operator = true;
		    }
		}
	    }
	/* Check that the formal parameter is an atom. */
	else if ( ! lmin_atom_is( car( var ) ) )
	    return lmin_errex_err_make( "parameter not an ATOM - \"%s\"", lmin_tocstring( car( var ) ) );
	}
    /* Ok. */
    return t;
    }

/* Check one typespec and val. */
static lmin_cellidx check_type( const char* spec, lmin_cellidx val )
    {
    size_t len;
    const char* cp;
    int i;

    /* Loop through the types in the typespec. */
    cp = spec;
    while ( *cp != '\0' )
	{
	len = strcspn( cp, punctuation );
	if ( len == 0 )
	    return t;
	/* Look for a matching type. */
	i = find_type( cp );
	if ( i == -1 )
	    return lmin_errex_err_make( "unknown typespec - \"%s\"", spec );
	/* Check if the value matches. */
	if ( types[i].pred( val ) )
	    return t;
	/* Move on to the next type. */
	cp += len;
	if ( *cp != '\0' && strchr( punctuation, *cp ) != (char*) 0 )
	    ++cp;
	if ( *cp != '\0' && strchr( punctuation, *cp ) != (char*) 0 )
	    return lmin_errex_err_make( "invalid typespec - \"%s\"", spec );
	}
    return lmin_errex_err_make( "arg not %s - \"%s\"", spec, lmin_tocstring( val ) );
    }

/* Check an evaluated argument list against the formal parameters
** list, including optional typespecs. Usually the second thing
** done by a C primitive function.
*/
lmin_cellidx lmin_check_types( lmin_cellidx vars, lmin_cellidx vals )
    {
    lmin_cellidx var, val, r;
    const char* typespec;
    const char* prev_typespec = (const char*) 0;
    char lc;
    bool operator = false, more_matching_allowed = false, no_more_allowed = false;

    /* Look through the vars, checking that there's a corresponding
    ** val, that the val's type matches an optional typespec, and that
    ** the var is an atom.
    */
    for ( var = vars, val = vals; lmin_cons_is( var ); var = cdr( var ), val = cdr( val ) )
	{
	if ( ! lmin_cons_is( val ) )
	    {
	    /* Ran out of vals before vars. Is there a typespec? */
	    if ( lmin_str_is( car( var ) ) )
		{
		typespec = lmin_str_get( car( var ) );
		/* Check for operator. */
		if ( strlen( typespec ) > 0 )
		    {
		    lc = typespec[strlen( typespec ) - 1];
		    if ( lc == '*' || lc == '?' )
			/* Star and qmark allow missing values. */
			return t;
		    }
		/* Skip past typespec to give proper error message. */
		var = cdr( var );
		}
	    if ( lmin_cons_is( var ) )
		return lmin_errex_err_make( "missing value for parameter \"%s\"", lmin_tocstring( car( var ) ) );
	    else
		return lmin_errex_err_make( "missing value" );
	    }

	/* Check for a typespec. */
	if ( lmin_str_is( car( var ) ) )
	    {
	    /* Got a typespec - check that the val matches it. */
	    typespec = lmin_str_get( car( var ) );
	    r = check_type( typespec, car( val ) );
	    if ( lmin_errex_is( r ) )
		return r;
	    if ( strlen( typespec ) > 0 )
		{
		/* If the typespec has an operator at the end, note it. */
		lc = typespec[strlen( typespec ) - 1];
		if ( strchr( operators, lc ) != (char*) 0 )
		    {
		    if ( operator )
			return lmin_errex_err_make( "typespecs have multiple operators" );
		    operator = true;
		    if ( lc == '*' || lc == '+' )
			/* Star and plus allow extra values if they match. */
			more_matching_allowed = true;
		    else if ( lc == '?' )
			/* Qmark disallows extra values. */
			no_more_allowed = true;
		    }
		}
	    /* Skip past the typespec. */
	    prev_typespec = typespec;
	    var = cdr( var );
	    if ( ! lmin_cons_is( var ) )
		break;
	    }
	/* Check that the formal parameter is an atom. */
	if ( ! lmin_atom_is( car( var ) ) )
	    return lmin_errex_err_make( "parameter not an ATOM - \"%s\"", lmin_tocstring( car( var ) ) );
	}

    /* Out of vars. Are there more vals to deal with? */
    if ( lmin_cons_is( val ) )
	{
	if ( no_more_allowed )
	    return lmin_errex_err_make( "extra values not allowed" );
	if ( more_matching_allowed )
	    {
	    /* There are more vals and they must match the saved typespec. */
	    for ( ; lmin_cons_is( val ); val = cdr( val ) )
		{
		r = check_type( prev_typespec, car( val ) );
		if ( lmin_errex_is( r ) )
		    return r;
		}
	    }
	}

    return t;
    }


/* Utility routines */

/* Make an association and add it to an alist. Returns ((key . datum) . alist) */
static lmin_cellidx acons( lmin_cellidx key, lmin_cellidx datum, lmin_cellidx alist )
    {
    return cons( cons( key, datum ), alist );
    }

/* Look up a key in an alist, return its value or error if not found. */
static lmin_cellidx assoc( lmin_cellidx key, lmin_cellidx alist )
    {
    const char* as;
    lmin_cellidx al;
    for ( al = alist; lmin_cons_is( al ); al = cdr( al ) )
	{
	if ( lmin_atom_idx_get( key ) == lmin_atom_idx_get( car( car( al ) ) ) )
	    return cdr( car( al ) );
	}
    /* Not found. See if there's an approximate match to return
    ** as a suggestion.
    */
    as = lmin_atom_str_get( key );
    for ( al = alist; lmin_cons_is( al ); al = cdr( al ) )
	{
	/* Check for wrong case and/or prefix. */
	const char* als = lmin_atom_str_get( car( car( al ) ) );
	if ( strcasecmp( as, als ) == 0 ||
	     ( strlen( as ) + 1 == strlen( als ) &&
	       strncasecmp( as, als, strlen( as ) ) == 0 ) ||
	     ( strlen( as ) == strlen( als ) + 1 &&
	       strncasecmp( as, als, strlen( als ) ) == 0 ) )
	    return lmin_errex_err_make( "symbol not found - \"%s\" - did you mean \"%s\"?", as, als );
	}
    /* Nope. Just return a generic error. */
    return lmin_errex_err_make( "symbol not found - \"%s\"", as );
    }

#ifdef notdef
/* Look up a datum in an alist, return the string of the atom that is
** bound to it.
*/
static const char* rassoc( lmin_cellidx datum, lmin_cellidx alist )
    {
    lmin_cellidx al;
    for ( al = alist; lmin_cons_is( al ); al = cdr( al ) )
	if ( cdr( car( al ) ) == datum )
	    return lmin_atom_str_get( car( car( al ) ) );
    return "???";
    }
#endif

static lmin_cellidx callstack;

/* Evaluate an expression. */
static lmin_cellidx eval( lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx args, r;
    if ( lmin_atom_is( c ) )
	r = assoc( c, e );
    else if ( lmin_cons_is( c ) )
	{
	lmin_cellidx f = eval( car( c ), e );
	if ( lmin_errex_is( f ) )
	    return f;
	callstack = lmin_cons_make( car( c ), callstack );
	args = cdr( c );
	if ( lmin_prim_is( f ) )
	    r = invoke_primitive( f, args, e );
	else if ( lmin_closure_is( f ) )
	    r = invoke_closure( f, args, e );
	else if ( lmin_macro_is( f ) )
	    r = invoke_macro( f, args, e );
	else
	    r = lmin_errex_err_make( "not executable - \"%s\"", lmin_tocstring( f ) );
	callstack = cdr( callstack );
	}
    else
	r = c;
    return r;
    }

/* Bind a list of values to a list of variable names. */
static lmin_cellidx bind( lmin_cellidx vars, lmin_cellidx vals, lmin_cellidx e )
    {
    if ( not( vars ) )
	return e;
    /* If it's a string typespec then skip it. */
    if ( lmin_str_is( car( vars ) ) )
	return bind( cdr( vars ), vals, e );
    if ( lmin_cons_is( vars ) )
	{
	/* If we run out of vals, bind the rest of the vars to nil. */
	if ( not( vals ) )
	    return bind( cdr( vars ), nil, acons( car( vars ), nil, e ) );
	return bind( cdr( vars ), cdr( vals ), acons( car( vars ), car( vals ), e ) );
	}
    return acons( vars, vals, e );
    }

/* Run primitive f on args. */
static lmin_cellidx invoke_primitive( lmin_cellidx f, lmin_cellidx args, lmin_cellidx callenv )
    {
    lmin_cellidx vars = lmin_prim_vars_get( f );
    lmin_cellidx vals, r;

    /* If the call environment is nil, use the global environment. */
    if ( not( callenv ) )
	callenv = env;

    if ( cell_special_is( f ) )
	{
	/* Special forms get their arguments uninterpreted. */
	vals = args;
	}
    else
	{
	/* Non-special forms get the arguments evaluated, error-checked,
	** and type-checked.
	**
	** First, evaluate the arguments in the environment of the call.
	*/
	vals = lmin_eval_args( args, callenv );

	/* Check the evaluated args for errors. */
	r = lmin_check_errs( vals );
	if ( lmin_errex_is( r ) )
	    return r;

	/* Check the args for count and type matching. */
	r = lmin_check_types( vars, vals );
	if ( lmin_errex_is( r ) )
	    return r;
	}

    /* And run it. Don't have to do a bind, primitives access their
    ** arguments by position, not name.
    */
    return (lmin_prim_fp_get( f ))( f, vals, callenv );
    }

/* Evaluate closure f on args. */
static lmin_cellidx invoke_closure( lmin_cellidx f, lmin_cellidx args, lmin_cellidx callenv )
    {
    lmin_cellidx vars = lmin_closure_vars_get( f );
    lmin_cellidx body = lmin_closure_body_get( f );
    lmin_cellidx defenv = lmin_closure_defenv_get( f );
    lmin_cellidx vals, r;

    /* If either the call or definition environments are nil, use the
    ** global environment.
    */
    if ( not( callenv ) )
	callenv = env;
    if ( not( defenv ) )
	defenv = env;

    if ( cell_special_is( f ) )
	/* Special forms get their arguments uninterpreted. */
	vals = args;
    else
	{
	/* Non-special forms get the arguments evaluated, error-checked,
	** and type-checked.
	**
	** First, evaluate the arguments in the environment of the call.
	** The closure itself gets evaluated in the environment it was
	** defined in - that's lexical scope.
	*/
	vals = lmin_eval_args( args, callenv );

	/* Check the evaluated args for errors. */
	r = lmin_check_errs( vals );
	if ( lmin_errex_is( r ) )
	    return r;

	/* Check the args for count and type matching. */
	r = lmin_check_types( vars, vals );
	if ( lmin_errex_is( r ) )
	    return r;
	}

    /* And eval it. */
    return eval( body, bind( vars, vals, defenv ) );
    }

/* Expand macro f with args. */
static lmin_cellidx invoke_macro( lmin_cellidx f, lmin_cellidx args, lmin_cellidx callenv )
    {
    return eval( substitute( lmin_macro_vars_get( f ), args, lmin_macro_body_get( f ) ), callenv );
    }

/* Traverse macro body, substituting parameters. */
static lmin_cellidx traverse_substitute( lmin_cellidx c, lmin_cellidx me )
    {
    lmin_cellidx nc;
    size_t i;
    if ( lmin_atom_is( c ) )
	{
	nc = assoc( c, me );
	if ( lmin_errex_is( nc ) )
	    return c;
	else
	    return nc;
	}
    else if ( lmin_cons_is( c ) )
	return lmin_cons_make( traverse_substitute( car( c ), me ), traverse_substitute( cdr( c ), me ) );
    else if ( lmin_closure_is( c ) )
	return lmin_closure_make( traverse_substitute( lmin_closure_vars_get( c ), me ), traverse_substitute( lmin_closure_body_get( c ), me ), lmin_closure_defenv_get( c ) );
    else if ( lmin_macro_is( c ) )
	return lmin_macro_make( traverse_substitute( lmin_macro_vars_get( c ), me ), traverse_substitute( lmin_macro_body_get( c ), me ) );
    else if ( lmin_vector_is( c ) )
	{
	nc = lmin_vector_make( lmin_vector_len_get( c ), traverse_substitute( cells[c].u.vec.fill, me ) );
	for ( i = 0; i < lmin_vector_len_get( c ); ++i )
	    lmin_vector_set( nc, i, traverse_substitute( lmin_vector_get( c, i ), me ) );
	return nc;
	}
    else
	return c;
    }

/* Substitute parameters in a macro. */
static lmin_cellidx substitute( lmin_cellidx vars, lmin_cellidx vals, lmin_cellidx body )
    {
    /* Make an empty environment just for the macro parametrers. */
    lmin_cellidx me = nil;
    /* Bind the parameters. */
    for ( ; lmin_cons_is( vars ) && lmin_cons_is( vals ); vars = cdr( vars ), vals = cdr( vals ) )
	me = acons( car( vars ), car( vals ), me );
    if ( ! not( vals ) )
	return lmin_errex_err_make( "extra arg" );
    /* Traverse the body, substituting any atoms that match parameters. */
    return traverse_substitute( body, me );
    }

/* Add a prim to an environment. */
static lmin_cellidx prim_make( const char* name, lmin_prim_fp fp, const char* vars, lmin_cellidx e, bool special )
    {
    lmin_cellidx a = lmin_atom_make( name );
    lmin_cellidx v = lmin_parse( vars );
    lmin_cellidx c = cell_make( PRIM );
    lmin_cellidx r;
    if ( lmin_errex_is( v ) )
	{
	char buf[100];
	snprintf( buf, sizeof(buf), "prim_make(\"%s\")", name );
	lmin_show_errex( (FILE*) 0, buf, 0, v );
	v = nil;
	}
    else
	{
	r = check_typespecs( v );
	if ( lmin_errex_is( r ) )
	    {
	    char buf[100];
	    snprintf( buf, sizeof(buf), "prim_make(\"%s\")", name );
	    lmin_show_errex( (FILE*) 0, buf, 0, r );
	    v = nil;
	    }
	}
    cells[c].u.prim.fp = fp;
    cells[c].u.prim.vars = v;
    if ( special )
	cell_special_set( c );
    return acons( a, c, e );
    }

void lmin_load_addon( const char* name, const char** strs, int nstrs )
    {
    char* addbuf;
    const char* cp;
    size_t addbuf_size, needed_size;
    int i;
    lmin_cellidx c, r;

    addbuf_size = 1000;
    addbuf = (char*) MALLOC( addbuf_size );
    if ( addbuf == (char*) 0 )
	{
	fprintf( stderr, "liblmin: out of memory\n" );
	exit( EX_SOFTWARE );
	}
    addbuf[0] = '\0';

    for ( i = 0; i < nstrs; ++i )
	{
	/* Is this string blank? */
	cp = strs[i] + strspn( strs[i], " \t\r\n" );
	if ( *cp == '\0' || *cp == ';' )
	    continue;

	needed_size = strlen( addbuf ) + strlen( strs[i] ) + 1;
	if ( needed_size > addbuf_size )
	    {
	    addbuf_size = needed_size * 2;
	    addbuf = (char*) REALLOC( (void*) addbuf, addbuf_size );
	    if ( addbuf == (char*) 0 )
		{
		fprintf( stderr, "liblmin: out of memory\n" );
		FREE( addbuf );
		exit( EX_SOFTWARE );
		}
	    }
	strcat( addbuf, strs[i] );
	c = lmin_parse( addbuf );
	if ( c == lmin_err_incomplete )
	    /* Collect any garbage from parsing the incomplete expression. */
	    lmin_gc();
	else
	    {
	    if ( lmin_errex_is( c ) )
		{
		lmin_show_errex( (FILE*) 0, name, i + 1, c );
		lmin_term();
		FREE( addbuf );
		exit( EX_SOFTWARE );
		}
	    r = eval( c, env );
	    if ( lmin_errex_is( r ) )
		{
		lmin_show_errex( (FILE*) 0, name, i + 1, r );
		lmin_term();
		FREE( addbuf );
		exit( EX_SOFTWARE );
		}
	    addbuf[0] = '\0';
	    }
	}

    if ( addbuf[0] != '\0' )
	{
	lmin_show_errex( (FILE*) 0, name, i, lmin_err_incomplete );
	lmin_term();
	FREE( addbuf );
	exit( EX_SOFTWARE );
	}

    FREE( addbuf );
    }

static void load_addons( void )
    {
    const char* builtins[] = {
#include "builtins.h"
	};

    lmin_load_addon( "builtins", builtins, sizeof(builtins) / sizeof(*builtins) );
    }

/* Append to a list in-place. Only works on existing lists, not nil. */
static void mutable_append( lmin_cellidx l, lmin_cellidx c )
    {
    while ( ! not( cdr( l ) ) )
	l = cdr( l );
    lmin_cons_cdr_set( l, cons( c, nil ) );
    }

/* Calls a LISP function from C. The first arg is the name of the
** function; the rest are lmin_cellidx; the last argument must be
** lmin_nil.
*/
lmin_cellidx lmin_call( const char* name, ... )
    {
    va_list ap;
    lmin_cellidx c, s;
    s = cons( lmin_atom_make( name ), nil );
    va_start( ap, name );
    for (;;)
	{
	c = va_arg( ap, lmin_cellidx );
	if ( lmin_nil_is( c ) )
	    break;
	mutable_append( s, c );
	}
    va_end( ap );
    return lmin_eval( s, env );
    }

/* Calls a LISP function from C without arg evaluation. The first arg is
** the name of the function; the rest are lmin_cellidx; the last argument
** must be lmin_nil.
*/
static lmin_cellidx lmin_callq( const char* name, ... )
    {
    va_list ap;
    lmin_cellidx c, s;
    s = cons( lmin_atom_make( name ), nil );
    va_start( ap, name );
    for (;;)
	{
	c = va_arg( ap, lmin_cellidx );
	if ( lmin_nil_is( c ) )
	    break;
	mutable_append( s, cons( lmin_atom_make( "quote" ), cons( c, nil ) ) );
	}
    va_end( ap );
    return lmin_eval( s, env );
    }

/* Return the length of a list. */
size_t lmin_list_length( lmin_cellidx c )
    {
    size_t i = 0;
    while ( ! not( c ) )
	{
	++i;
	c = cdr( c );
	}
    return i;
    }

/* Reverses a list, with no argument evaluation. */
static lmin_cellidx reverseq( lmin_cellidx c )
    {
    return lmin_callq( "reverse", c, nil );
    }

/* Convert an expression to a STR. */
lmin_cellidx lmin_tostring( lmin_cellidx c )
    {
    char buf[10000];
    lmin_cellidx r;
    FILE* fp = fmemopen( &buf, sizeof(buf), "w" );
    if ( fp == (FILE*) 0 )
	return lmin_errex_err_make( "str memory file open failed" );
    lmin_write( c, fp );
    r = lmin_str_make( buf );
    fclose( fp );
    return r;
    }

/* Convert an expression to a C string (that gets garbage collected later). */
const char* lmin_tocstring( lmin_cellidx c )
    {
    return lmin_str_get( lmin_tostring( c ) );
    }

/* Some list accessors. */
lmin_cellidx lmin_first( lmin_cellidx c )
    {
    return car( c );
    }
lmin_cellidx lmin_second( lmin_cellidx c )
    {
    return car( cdr( c ) );
    }
lmin_cellidx lmin_third( lmin_cellidx c )
    {
    return car( cdr( cdr( c ) ) );
    }
lmin_cellidx lmin_fourth( lmin_cellidx c )
    {
    return car( cdr( cdr( cdr( c ) ) ) );
    }
lmin_cellidx lmin_fifth( lmin_cellidx c )
    {
    return car( cdr( cdr( cdr( cdr( c ) ) ) ) );
    }

/* Calls a predicate on members of a list; all must match. */
static bool all_pred( lmin_cellidx list, pred_fp pfp )
    {
    while ( ! not( list ) )
	{
	if ( ! pfp( car( list ) ) )
	    return false;
	list = cdr( list );
	}
    return true;
    }

/* Debugging aid that sends all of a cell's fields to stdout. */
static void celldump( lmin_cellidx c )
    {
    FILE* fp = lmin_stream_get( lmin_stdout );
    lmin_celltype typ = ct( c );
    fprintf( fp, "idx:            %ld\n", c );
    fprintf( fp, "typ:            %d (%s)\n", typ, lmin_celltype_str( typ ) );
    fprintf( fp, "flags:          %#x\n", cells[c].flags );
    fprintf( fp, "  permanent:      %c\n", cell_permanent_is( c ) ? 'T' : 'F' );
    fprintf( fp, "  marked:         %c\n", cell_marked_is( c ) ? 'T' : 'F' );
    switch ( typ )
	{
	case NIL:
	break;
	case ATOM:
	fprintf( fp, "atom.idx:       %ld (%s)\n", lmin_atom_idx_get( c ), atom_str_get( lmin_atom_idx_get( c ) ) );
	break;
	case CONS:
	fprintf( fp, "cons.ar:        %ld\n", lmin_cons_car_get( c ) );
	fprintf( fp, "cons.dr:        %ld\n", lmin_cons_cdr_get( c ) );
	break;
	case PRIM:
	fprintf( fp, "  special:        %c\n", cell_special_is( c ) ? 'T' : 'F' );
	fprintf( fp, "prim.fp:        %#lx\n", (unsigned long) lmin_prim_fp_get( c ) );
	fprintf( fp, "prim.vars:      %s\n", lmin_tocstring( lmin_prim_vars_get( c ) ) );
	break;
	case CLOSURE:
	fprintf( fp, "  special:       %c\n", cell_special_is( c ) ? 'T' : 'F' );
	fprintf( fp, "closure.vars:    %ld\n", lmin_closure_vars_get( c ) );
	fprintf( fp, "closure.body:    %ld\n", lmin_closure_body_get( c ) );
	fprintf( fp, "closure.defenv:  %ld\n", lmin_closure_defenv_get( c ) );
	break;
	case MACRO:
	fprintf( fp, "macro.vars:     %ld\n", lmin_macro_vars_get( c ) );
	fprintf( fp, "macro.body:     %ld\n", lmin_macro_body_get( c ) );
	break;
	case NUM:
	fprintf( fp, "  integer:        %c\n", cell_integer_is( c ) ? 'T' : 'F' );
	fprintf( fp, "num.in:         %ld\n", lmin_num_integer_get( c ) );
	fprintf( fp, "num.fl:         %g\n", lmin_num_float_get( c ) );
	break;
	case CHR:
	fprintf( fp, "chr.ch:         '%c'\n", lmin_chr_get( c ) );
	break;
	case STR:
	fprintf( fp, "str.s:          \"%s\"\n", lmin_str_get( c ) );
	fprintf( fp, "str.len:        %lu\n", lmin_str_len_get( c ) );
	break;
	case STREAM:
	fprintf( fp, "stream.fp:      %p\n", (void*) lmin_stream_get( c ) );
	break;
	case VECTOR:
	fprintf( fp, "vec.maxlen:     %ld\n", cells[c].u.vec.maxlen );
	fprintf( fp, "vec.curlen:     %ld\n", cells[c].u.vec.curlen );
	fprintf( fp, "vec.fill:       %ld\n", cells[c].u.vec.fill );
	break;
	case DATA:
	fprintf( fp, "data.ptr:       %p\n", lmin_data_ptr_get( c ) );
	fprintf( fp, "data.freefp:    %#lx\n", (unsigned long) lmin_data_freefp_get( c ) );
	break;
	case ERREX:
	fprintf( fp, "errex.payload:  %s\n", lmin_tocstring( lmin_errex_payload_get( c ) ) );
	break;
	}
    fprintf( fp, "next_idx:      %ld\n", cells[c].next_idx );
    }


/* Primitives */

/* First define the special forms. For various reasons, these don't
** want the standard behavior of evaluating arguments, checking them
** for errors, and checking them against any typespecs. If them need
** some but not all of those to happen, they have to include the
** code themselves.
*/

/* Needs to be a special form because it returns its argument unevaluated. */
static lmin_cellidx prim_quote( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    if ( ! not( cdr( c ) ) )
	return lmin_errex_err_make( "extra arg" );
    return car( c );
    }

/* Needs to be a special form because it uses the first argument unevaluated. */
static lmin_cellidx prim_define( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx var = car( c ), val = eval( car( cdr( c ) ), e );
    if ( lmin_errex_is( val ) )
	return val;
    if ( ! not( cdr( cdr( c ) ) ) )
	return lmin_errex_err_make( "extra arg" );
    return lmin_define( var, val );
    }

/* Needs to be a special form because it uses both arguments unevaluated. */
static lmin_cellidx prim_lambda( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    if ( ! not( cdr( cdr( c ) ) ) )
	return lmin_errex_err_make( "extra arg" );
    return lmin_closure_make( car( c ), car( cdr( c ) ), e );
    }

/* Needs to be a special form because it uses its arguments unevaluated. */
static lmin_cellidx prim_macro( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    if ( ! not( cdr( cdr( c ) ) ) )
	return lmin_errex_err_make( "extra arg" );
    return lmin_macro_make( car( c ), car( cdr( c ) ) );
    }

/* Needs to be a special form because it does lazy evaluation. */
static lmin_cellidx prim_or( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx r;
    if ( not( c ) )
	return lmin_errex_err_make( "or: value required" );
    while ( ! not( c ) )
	{
	r = eval( car( c ), e );
	if ( lmin_errex_is( r ) )
	    return r;
	if ( ! not( r ) )
	    return t;
	c = cdr( c );
	}
    return nil;
    }

/* Needs to be a special form because it does lazy evaluation. */
static lmin_cellidx prim_and( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx r;
    if ( not( c ) )
	return lmin_errex_err_make( "and: value required" );
    while ( ! not( c ) )
	{
	r = eval( car( c ), e );
	if ( lmin_errex_is( r ) )
	    return r;
	if ( not( r ) )
	    return nil;
	c = cdr( c );
	}
    return t;
    }

/* Needs to be a special form because it does lazy evaluation. */
static lmin_cellidx prim_cond( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx r;
    for (;;)
	{
	if ( ! lmin_cons_is( c ) )
	    return nil;
	r = eval( car( car( c ) ), e );
	if ( lmin_errex_is( r ) )
	    return r;
	if ( ! not( r ) )
	    return eval( car( cdr( car( c ) ) ), e );
	c = cdr( c );
	}
    }

/* Needs to be a special form because it does lazy evaluation. */
static lmin_cellidx prim_if( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx r, b;
    r = eval( car( c ), e );
    if ( lmin_errex_is( r ) )
	return r;
    if ( ( ! not( cdr( cdr( c ) ) ) ) && ( ! not( cdr( cdr( cdr( c ) ) ) ) ) )
	return lmin_errex_err_make( "extra arg" );
    if ( ! not( r ) )
	b = cdr( c );
    else
	b = cdr( cdr( c ) );
    if ( lmin_errex_is( b ) )
	return b;
    if ( not( b ) )
	return nil;
    return eval( car( b ), e );
    }

/* Checks if an atom is in an atom list. */
static bool atom_member( lmin_cellidx a, lmin_cellidx al )
    {
    while ( ! not( al ) )
	{
	if ( lmin_atom_idx_get( a ) == lmin_atom_idx_get( car( al ) ) )
	    return true;
	al = cdr( al );
	}
    return false;
    }

/* Test whether a let's subexpression is a variable assignment.
**
** An assignment must be:
**   - a proper list with exactly two items
**   - the first item must be an atom
**   - must not have been seen before in this let
**   - and must not be currently bound to something executable
*/
static bool let_is( lmin_cellidx c, lmin_cellidx* atomlistP, lmin_cellidx e )
    {
    lmin_cellidx v;
    if ( ! lmin_cons_is( c ) )
	return false;
    if ( ! lmin_atom_is( car( c ) ) )
	return false;
    if ( ! lmin_cons_is( cdr( c ) ) )
	return false;
    if ( ! lmin_nil_is( cdr( cdr( c ) ) ) )
	return false;
    if ( atom_member( car( c ), *atomlistP ) )
	return false;
    *atomlistP = cons( car( c ), *atomlistP );
    v = assoc( car( c ), e );
    if ( lmin_prim_is( v ) || lmin_closure_is( v ) || lmin_macro_is( v ) )
	 return false;
    return true;
    }

/* Needs to be a special form so it can evaluate the args in the proper
** order and environment.
*/
static lmin_cellidx prim_leta( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx atomlist = nil, r, x = nil;
    for ( ; lmin_cons_is( c ) && let_is( car( c ), &atomlist, e ); c = cdr( c ) )
	{
	r = eval( car( cdr( car( c ) ) ), e );
	if ( lmin_errex_is( r ) )
	    return r;
	e = acons( car( car( c ) ), r, e );
	}
    for ( ; lmin_cons_is( c ); c = cdr( c ) )
	{
	x = eval( car( c ), e );
	if ( lmin_errex_is( x ) )
	    break;
	}
    return x;
    }

/* Needs to be a special form so it can evaluate the args in the proper
** order and environment.
*/
static lmin_cellidx prim_let( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    /* Save the current environment and use it to evaluate the assignments. */
    lmin_cellidx saved_e = e;
    lmin_cellidx atomlist = nil, r, x = nil;
    for ( ; lmin_cons_is( c ) && let_is( car( c ), &atomlist, e ); c = cdr( c ) )
	{
	r = eval( car( cdr( car( c ) ) ), saved_e );
	if ( lmin_errex_is( r ) )
	    return r;
	e = acons( car( car( c ) ), r, e );
	}
    for ( ; lmin_cons_is( c ); c = cdr( c ) )
	{
	x = eval( car( c ), e );
	if ( lmin_errex_is( x ) )
	    return x;
	}
    return x;
    }

/* Needs to be a special form so it can evaluate the args in the proper
** order and environment.
*/
static lmin_cellidx prim_letrec( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx lets = nil, non_lets = nil, bindings = nil;
    lmin_cellidx atomlist = nil, r, x = nil;

    /* Letrec is the easiest of the three let variations to explain to
    ** users, but by far the most complicated to implement.
    **
    ** First step is to go through the args, separating them into
    ** lets and non-lets.
    */
    for ( ; lmin_cons_is( c ); c = cdr( c ) )
	{
	if ( let_is( car( c ), &atomlist, e ) )
	    lets = cons( car( c ), lets );
	else
	    non_lets = cons( car( c ), non_lets );
	}
    /* Reverse both list to get them back in the proper order. */
    lets = reverseq( lets );
    non_lets = reverseq( non_lets );

    /* Now we go through the lets creating bindings, but with a placeholder
    ** value. We also save the bindings in a list.
    */
    for ( c = lets; lmin_cons_is( c ); c = cdr( c ) )
	{
	e = acons( car( car( c ) ), nil, e );
	bindings = cons( car( e ), bindings );
	}
    /* And reverse the bindings list. */
    bindings = reverseq( bindings );

    /* Next we loop through the lets again, evaluating them and
    ** stuffing the results into the previously created placeholders.
    */
    for ( c = lets; lmin_cons_is( c ); c = cdr( c ) )
	{
	r = eval( car( cdr( car( c ) ) ), e );
	if ( lmin_errex_is( r ) )
	    return r;
	lmin_cons_cdr_set( car( bindings ), r );
	bindings = cdr( bindings );
	}

    /* And finally, evaluate the saved non-lets and return the last result. */
    for ( c = non_lets; lmin_cons_is( c ); c = cdr( c ) )
	{
	x = eval( car( c ), e );
	if ( lmin_errex_is( x ) )
	    return x;
	}
    return x;
    }

/* Needs to be a special form because it's a control structure. */
static lmin_cellidx prim_progn( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx r = nil;
    while ( lmin_cons_is( c ) )
	{
	r = eval( car( c ), e );
	if ( lmin_errex_is( r ) )
	    return r;
	c = cdr( c );
	}
    return r;
    }

/* Needs to be a special form because it's a control structure. */
static lmin_cellidx prim_while( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx r, x = nil, d;
    for (;;)
	{
	r = eval( car( c ), e );
	if ( lmin_errex_is( r ) )
	    return r;
	if ( not( r ) )
	    return x;
	d = cdr( c );
	while ( lmin_cons_is( d ) )
	    {
	    x = eval( car( d ), e );
	    if ( lmin_errex_is( x ) )
		return x;
	    d = cdr( d );
	    }
	}
    }

/* Needs to be a special form because it's a control structure. */
static lmin_cellidx prim_until( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx d, x = nil;
    do
	{
	for ( d = c; lmin_cons_is( d ); d = cdr( d ) )
	    {
	    x = eval( car( d ), e );
	    if ( lmin_errex_is( x ) )
		return x;
	    }
	}
    while ( not( x ) );
    return x;
    }

/* Needs to be a special form because it's a control structure. */
static lmin_cellidx prim_catch( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx tag = nil, r = eval( car( c ), e );
    if ( lmin_atom_is( r ) )
	{
	tag = r;
	c = cdr( c );
	if ( ! lmin_cons_is( c ) )
	    return nil;
	r = eval( car( c ), e );
	}
    for (;;)
	{
	if ( lmin_errex_is( r ) )
	    {
	    if ( lmin_errex_exception_is( r ) )
		{
		lmin_cellidx etag = lmin_errex_exception_tag_get( r );
		if ( tag == nil || etag == nil ||
		     lmin_atom_idx_get( tag ) == lmin_atom_idx_get( etag ) )
		    return lmin_errex_exception_value_get( r );
		else
		    return r;
		}
	    else
		return r;
	    }
	c = cdr( c );
	if ( ! lmin_cons_is( c ) )
	    break;
	r = eval( car( c ), e );
	}
    return r;
    }

/* Needs to be a special form because it uses its first argument unevaluated. */
static lmin_cellidx prim_setq( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = car( c );
    lmin_cellidx val2 = eval( car( cdr( c ) ), e );
    if ( lmin_errex_is( val2 ) )
	return val2;
    if ( ! lmin_atom_is( val1 ) )
	return lmin_errex_err_make( "setq!: not an ATOM - \"%s\"", lmin_tocstring( val1 ) );
    if ( ! not( cdr( cdr( c ) ) ) )
	return lmin_errex_err_make( "extra arg" );
    for (;;)
	{
	if ( ! lmin_cons_is( e ) )
	    {
	    /* Not found in e. We can't create a new binding in e
	    ** because we can't change it. Instead we create a new global
	    ** binding. Better than nothing.
	    */
	    env = acons( val1, val2, env );
	    break;
	    }
	if ( lmin_atom_idx_get( val1 ) == lmin_atom_idx_get( car( car( e ) ) ) )
	    {
	    /* Found it. */
	    if ( ! lmin_cons_is( car( e ) ) )
		return lmin_errex_err_make( "setq!: not a CONS - \"%s\"", lmin_tocstring( car( e ) ) );
	    lmin_cons_cdr_set( car( e ), val2 );
	    break;
	    }
	e = cdr( e );
	}
    return val2;
    }

/* Needs to be a special form because it uses its argument unevaluated. */
static lmin_cellidx prim_permq( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    if ( ! not( cdr( c ) ) )
	return lmin_errex_err_make( "extra arg" );
    return lmin_perm( car( c ) );
    }

/* This one needs to be a special form so that the possible ERREX it is
** checking doesn't get automatically propagated as the primitive's
** own result.
*/
static lmin_cellidx prim_errexp( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = eval( car( c ), e );
    if ( ! not( cdr( c ) ) )
	return lmin_errex_err_make( "extra arg" );
    return lmin_errex_is( val ) ? t : nil;
    }

/* Needs to be a special form so it can properly time the evaluation
** of the argument.
*/
static lmin_cellidx prim_time( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    struct timeval tv1, tv2;
    struct rusage ru1, ru2;
    lmin_cellidx v;
    double r, u, s;
    FILE* fp = lmin_stream_get( lmin_stdout );

    if ( ! not( cdr( c ) ) )
	return lmin_errex_err_make( "extra arg" );

    if ( gettimeofday( &tv1, (struct timezone*) 0 ) != 0 )
	return lmin_errex_err_make( "time: %s", strerror( errno ) );
    if ( getrusage( RUSAGE_SELF, &ru1 ) != 0 )
	return lmin_errex_err_make( "time: %s", strerror( errno ) );

    v = eval( car( c ), e );

    if ( gettimeofday( &tv2, (struct timezone*) 0 ) != 0 )
	return lmin_errex_err_make( "time: %s", strerror( errno ) );
    if ( getrusage( RUSAGE_SELF, &ru2 ) != 0 )
	return lmin_errex_err_make( "time: %s", strerror( errno ) );

    r = ( (double) tv2.tv_sec - (double) tv1.tv_sec ) + ( (double) tv2.tv_usec - (double) tv1.tv_usec ) / 1000000.0;
    u = ( (double) ru2.ru_utime.tv_sec - (double) ru1.ru_utime.tv_sec ) + ( (double) ru2.ru_utime.tv_usec - (double) ru1.ru_utime.tv_usec ) / 1000000.0;
    s = ( (double) ru2.ru_stime.tv_sec - (double) ru1.ru_stime.tv_sec ) + ( (double) ru2.ru_stime.tv_usec - (double) ru1.ru_stime.tv_usec ) / 1000000.0;
    fprintf( fp, "%.2fr %.2fu %.2fs\n", r, u, s );

    return v;
    }

/* And now the regular forms. */

static lmin_cellidx prim_cons( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c );
    lmin_cellidx val2 = lmin_second( c );
    return cons( val1, val2 );
    }

static lmin_cellidx prim_car( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return car( val );
    }

static lmin_cellidx prim_cdr( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return cdr( val );
    }

static lmin_cellidx prim_eval( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return eval( val, e );
    }

static lmin_cellidx prim_add( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    long in = 0;
    double fl = 0.0;
    bool integer_is = true, float_all = true;
    lmin_cellidx n;
    while ( ! not( c ) )
	{
	n = car( c );
	integer_is &= cell_integer_is( n );
	float_all &= ! cell_integer_is( n );
	in += lmin_num_integer_get( n );
	fl += lmin_num_float_get( n );
	c = cdr( c );
	}
    if ( float_all )
	return lmin_num_float_make( fl );
    return lmin_num_make( in, fl, integer_is );
    }

static lmin_cellidx prim_subtract( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    long in;
    double fl;
    bool integer_is, float_all;
    lmin_cellidx n;
    n = car( c );
    integer_is = cell_integer_is( n );
    float_all = ! integer_is;
    in = lmin_num_integer_get( n );
    fl = lmin_num_float_get( n );
    c = cdr( c );
    while ( ! not( c ) )
	{
	n = car( c );
	integer_is &= cell_integer_is( n );
	float_all &= ! cell_integer_is( n );
	in -= lmin_num_integer_get( n );
	fl -= lmin_num_float_get( n );
	c = cdr( c );
	}
    if ( float_all )
	return lmin_num_float_make( fl );
    return lmin_num_make( in, fl, integer_is );
    }

static lmin_cellidx prim_multiply( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    long in = 1;
    double fl = 1.0;
    bool integer_is = true, float_all = true;
    lmin_cellidx n;
    while ( ! not( c ) )
	{
	n = car( c );
	integer_is &= cell_integer_is( n );
	float_all &= ! cell_integer_is( n );
	in *= lmin_num_integer_get( n );
	fl *= lmin_num_float_get( n );
	c = cdr( c );
	}
    if ( float_all )
	return lmin_num_float_make( fl );
    return lmin_num_make( in, fl, integer_is );
    }

static lmin_cellidx prim_divide( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    long orig_in, in, n_in, prod;
    double fl, n_fl;
    bool integer_is, float_all;
    lmin_cellidx n;
    n = car( c );
    integer_is = cell_integer_is( n );
    float_all = ! integer_is;
    in = orig_in = lmin_num_integer_get( n );
    prod = 1;
    fl = lmin_num_float_get( n );
    c = cdr( c );
    while ( ! not( c ) )
	{
	n = car( c );
	integer_is &= cell_integer_is( n );
	float_all &= ! cell_integer_is( n );
	n_in = lmin_num_integer_get( n );
	if ( n_in == 0 )
	    {
	    integer_is = false;
	    }
	else
	    {
	    in /= n_in;
	    prod *= n_in;
	    }
	n_fl = lmin_num_float_get( n );
	if ( n_fl == 0.0 )
	    {
	    fl = NAN;
	    integer_is = false;
	    }
	else
	    fl /= n_fl;
	c = cdr( c );
	}
    if ( float_all )
	return lmin_num_float_make( fl );
    if ( integer_is && in * prod != orig_in )
	integer_is = false;
    return lmin_num_make( in, fl, integer_is );
    }

static lmin_cellidx prim_truncate( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    if ( isnan( cells[val].u.num.fl ) || cell_integer_is( val ) )
	return val;
    else
	return lmin_num_make( cells[val].u.num.in, trunc( cells[val].u.num.fl ), true );
    }

static lmin_cellidx prim_floor( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    if ( isnan( cells[val].u.num.fl ) || cell_integer_is( val ) )
	return val;
    return lmin_num_integer_make( (long) floor( lmin_num_float_get( val ) ) );
    }

static lmin_cellidx prim_lt( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    if ( lmin_num_is( val1 ) && lmin_num_is( val2 ) )
	{
	if ( lmin_num_integer_is( val1 ) && lmin_num_integer_is( val2 ) )
	    return lmin_num_integer_get( val1 ) < lmin_num_integer_get( val2 ) ? t : nil;
	else
	    return lmin_num_float_get( val1 ) < lmin_num_float_get( val2 ) ? t : nil;
	}
    else if ( lmin_chr_is( val1 ) && lmin_chr_is( val2 ) )
	return lmin_chr_get( val1 ) < lmin_chr_get( val2 ) ? t : nil;
    else if ( lmin_str_is( val1 ) && lmin_str_is( val2 ) )
	return strcmp( lmin_str_get( val1 ), lmin_str_get( val2 ) ) < 0 ? t : nil;
    else if ( lmin_atom_is( val1 ) && lmin_atom_is( val2 ) )
	return strcmp( lmin_atom_str_get( val1 ), lmin_atom_str_get( val2 ) ) < 0 ? t : nil;
    else
	return lmin_errex_err_make( "<: argument types don't match" );
    }

static lmin_cellidx prim_ash( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    long n = lmin_num_integer_get( val1 ), b = lmin_num_integer_get( val2 );
    if ( b > 0 )
	return lmin_num_integer_make( n << b );
    else if ( b < 0 )
	return lmin_num_integer_make( n >> -b );
    else
	return val1;
    }

static lmin_cellidx prim_sqrt( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_num_float_make( sqrt( lmin_num_float_get( val ) ) );
    }

static lmin_cellidx prim_expt( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    if ( lmin_num_integer_is( val1 ) && lmin_num_integer_is( val2 ) && lmin_num_integer_get( val2 ) >= 0 )
	{
	/* Special case for integers. */
	long a = lmin_num_integer_get( val1 );
	long b = lmin_num_integer_get( val2 );
	long p = 1;
	while ( b > 0 )
	    {
	    if ( b & 1 )
		{
		p *= a;
		--b;
		}
	    a *= a;
	    b >>= 1;
	    }
	return lmin_num_integer_make( p );
	}
    else
	{
	double a = lmin_num_float_get( val1 );
	double b = lmin_num_float_get( val2 );
	return lmin_num_float_make( pow( a, b ) );
	return lmin_num_float_make( pow( lmin_num_float_get( val1 ), lmin_num_float_get( val2 ) ) );
	}
    }

static lmin_cellidx prim_sin( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_num_float_make( sin( lmin_num_float_get( val ) ) );
    }

static lmin_cellidx prim_cos( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_num_float_make( cos( lmin_num_float_get( val ) ) );
    }

static lmin_cellidx prim_tan( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_num_float_make( tan( lmin_num_float_get( val ) ) );
    }

static lmin_cellidx prim_exp( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_num_float_make( exp( lmin_num_float_get( val ) ) );
    }

static lmin_cellidx prim_log( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_num_float_make( log( lmin_num_float_get( val ) ) );
    }

static lmin_cellidx prim_asin( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_num_float_make( asin( lmin_num_float_get( val ) ) );
    }

static lmin_cellidx prim_acos( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_num_float_make( acos( lmin_num_float_get( val ) ) );
    }

static lmin_cellidx prim_atan( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    if ( lmin_num_is( val2 ) )
	return lmin_num_float_make( atan2( lmin_num_float_get( val1 ), lmin_num_float_get( val2 ) ) );
    else
	return lmin_num_float_make( atan( lmin_num_float_get( val1 ) ) );
    }

static lmin_cellidx prim_eq( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    return val1 == val2 ? t : nil;
    }

static lmin_cellidx prim_eql( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    bool res;
    size_t i;
    if ( lmin_nil_is( val1 ) && lmin_nil_is( val2 ) )
	/* All NIL cells are eql. */
	res = true;
    else if ( not( val1 ) || not( val2 ) )
	/* Only one false? Not eql. */
	res = false;
    else if ( lmin_atom_is( val1 ) && lmin_atom_is( val2 ) )
	/* Atom cells are eql if they point to the same atom. */
	res = lmin_atom_idx_get( val1 ) == lmin_atom_idx_get( val2 );
    else if ( lmin_prim_is( val1 ) && lmin_prim_is( val2 ) )
	/* Primitives are eql if their function pointers are the same. */
	res = lmin_prim_fp_get( val1 ) == lmin_prim_fp_get( val2 );
    else if ( lmin_num_is( val1 ) && lmin_num_is( val2 ) )
	{
	/* Numeric comparison. */
	if ( cell_integer_is( val1 ) && cell_integer_is( val2 ) )
	    res = lmin_num_integer_get( val1 ) == lmin_num_integer_get( val2 );
	else
	    res = lmin_num_float_get( val1 ) == lmin_num_float_get( val2 );
	}
    else if ( lmin_chr_is( val1 ) && lmin_chr_is( val2 ) )
	/* Character comparison. */
	res = lmin_chr_get( val1 ) == lmin_chr_get( val2 );
    else if ( lmin_str_is( val1 ) && lmin_str_is( val2 ) )
	/* String comparison - check the lengths first, that's cheap. */
	res = lmin_str_len_get( val1 ) == lmin_str_len_get( val2 ) &&
	    strcmp( lmin_str_get( val1 ), lmin_str_get( val2 ) ) == 0;
    else if ( lmin_vector_is( val1 ) && lmin_vector_is( val2 ) )
	{
	/* Vector comparison - again check the lengths first. */
	res = lmin_str_len_get( val1 ) == lmin_str_len_get( val2 );
	if ( res )
	    {
	    for ( i = 0; i < lmin_str_len_get( val1 ); ++i )
		if ( not( prim_eql( f, cons( lmin_vector_get( val1, i ), cons( lmin_vector_get( val2, i ), nil ) ), e ) ) )
		    {
		    res = false;
		    break;
		    }
	    }
	}
    else
	/* Otherwise, they are eq if they are the same cell. */
	res = val1 == val2;
    return res ? t : nil;
    }

static lmin_cellidx prim_atomp( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_atom_is( val ) ? t : nil;
    }

static lmin_cellidx prim_consp( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_cons_is( val ) ? t : nil;
    }

static lmin_cellidx prim_closurep( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_closure_is( val ) ? t : nil;
    }

static lmin_cellidx prim_macrop( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_macro_is( val ) ? t : nil;
    }

static lmin_cellidx prim_primp( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_prim_is( val ) ? t : nil;
    }

static lmin_cellidx prim_numberp( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_num_is( val ) ? t : nil;
    }

static lmin_cellidx prim_integerp( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_num_integer_is( val ) ? t : nil;
    }

static lmin_cellidx prim_characterp( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_chr_is( val ) ? t : nil;
    }

static lmin_cellidx prim_stringp( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_str_is( val ) ? t : nil;
    }

static lmin_cellidx prim_streamp( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_stream_is( val ) ? t : nil;
    }

static lmin_cellidx prim_vectorp( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_vector_is( val ) ? t : nil;
    }

static lmin_cellidx prim_datap( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_data_is( val ) ? t : nil;
    }

static lmin_cellidx prim_not( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return not( val ) ? t : nil;
    }

static lmin_cellidx prim_assoc( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    return assoc( val1, val2 );
    }

static lmin_cellidx prim_rplaca( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    return lmin_cons_car_set( val1, val2 );
    }

static lmin_cellidx prim_rplacd( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    return lmin_cons_cdr_set( val1, val2 );
    }

static lmin_cellidx prim_write( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2;
    if ( not( cdr( c ) ) )
	val2 = lmin_stdout;
    else
	val2 = lmin_second( c );
    lmin_write( val1, lmin_stream_get( val2 ) );
    return t;
    }

static lmin_cellidx prim_write_string( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    FILE* fp;
    if ( not( cdr( c ) ) )
	fp = stdout;
    else
	fp = lmin_stream_get( lmin_second( c ) );
    fputs( lmin_str_get( val ), fp );
    return t;
    }

static lmin_cellidx prim_read( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val;
    if ( not( c ) )
	val = lmin_stdin;
    else
	val = lmin_first( c );
    return lmin_read( lmin_stream_get( val ), (int*) 0 );
    }

static lmin_cellidx prim_read_char( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val;
    int ic;
    if ( not( c ) )
	val = lmin_stdin;
    else
	val = lmin_first( c );
    ic = fgetc( lmin_stream_get( val ) );
    if ( ic == EOF )
	return lmin_errex_err_make( "read-char: EOF" );
    return lmin_chr_make( (char) ic );
    }

static lmin_cellidx prim_read_line( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val;
    char linebuf[1000];
    if ( not( c ) )
	val = lmin_stdin;
    else
	val = lmin_first( c );
    if ( fgets( linebuf, sizeof( linebuf ), lmin_stream_get( val ) ) == (char*) 0 )
	return lmin_errex_err_make( "read-line: EOF" );
    return lmin_str_make( linebuf );
    }

static lmin_cellidx prim_env( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    return env;
    }

static lmin_cellidx prim_callstack( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    return callstack;
    }

static lmin_cellidx prim_usleep( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    usleep( (useconds_t) lmin_num_integer_get( val ) );
    return t;
    }

static lmin_cellidx prim_random( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val;
    long n;
    if ( not( c ) )
	return lmin_num_integer_make( random() );
    val = lmin_first( c );
    n = lmin_num_integer_get( val );
    if ( n < 1 )
	return lmin_errex_err_make( "random: arg is not positive - \"%s\"", lmin_tocstring( val ) );
    return lmin_num_integer_make( random() % n );
    }

static lmin_cellidx prim_parse_integer( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    long n;
    const char* s;
    const char* endptr;
    s = lmin_str_get( val );
    n = strtol( lmin_str_get( val ), (char**) &endptr, 10 );
    if ( *endptr != '\0' )
	return lmin_errex_err_make( "parse_integer: malformed integer - \"%s\"", s );
    return lmin_num_integer_make( n );
    }

static lmin_cellidx prim_chr( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    long n;
    n = lmin_num_integer_get( val );
    if ( n < 0 || n > 127 )
	return lmin_errex_err_make( "chr: out of range - \"%s\"", lmin_tocstring( val ) );
    return lmin_chr_make( (char) n );
    }

static lmin_cellidx prim_chrnum( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_num_integer_make( lmin_chr_get( val ) );
    }

static lmin_cellidx prim_chr_tolower( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_chr_make( (char) tolower( lmin_chr_get( val ) ) );
    }

static lmin_cellidx prim_chr_toupper( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_chr_make( (char) toupper( lmin_chr_get( val ) ) );
    }

static lmin_cellidx prim_chr_isspace( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return isspace( lmin_chr_get( val ) ) ? t : nil;
    }

static lmin_cellidx prim_string( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_tostring( val );
    }

static lmin_cellidx prim_string_length( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    if ( lmin_chr_is( val ) )
	return lmin_num_integer_make( 1 );
    else
	return lmin_num_integer_make( (long) lmin_str_len_get( val ) );
    }

static lmin_cellidx prim_string_chrat( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );;
    return lmin_str_chrat( val1, (size_t) lmin_num_integer_get( val2 ) );
    }

static lmin_cellidx prim_string_substr( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    const char* s;
    size_t pos, len;
    s = lmin_str_get( val1 );
    pos = (size_t) lmin_num_integer_get( val2 );
    if ( not( cdr( cdr( c ) ) ) )
	len = strlen( s ) - pos;
    else
	len = (size_t) lmin_num_integer_get( lmin_third( c ) );
    if ( pos > lmin_str_len_get( val1 ) )
	return lmin_errex_err_make( "string_substr: pos out of bounds - \"%s\"", lmin_tocstring( val2 ) );
    if ( pos + len > lmin_str_len_get( val1 ) )
	return lmin_errex_err_make( "string_substr: out of bounds" );
    return lmin_str_makel( &s[pos], len );
    }

static lmin_cellidx prim_string_concat( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    size_t len;
    lmin_cellidx d, x, r;
    char twochar[2];
    char* rstr;
    const char* cp;

    /* First count up the total length needed. */
    len = 0;
    for ( d = c; ! not( d ); d = cdr( d ) )
	{
	x = car( d );
	if ( lmin_chr_is( x ) )
	    ++len;
	else
	    len += lmin_str_len_get( x );
	}
    /* Make a big enough string. */
    r = lmin_str_makel( "", len );
    /* And go through the args again, filling in the new string. */
    rstr = (char*) lmin_str_get( r );
    twochar[1] = '\0';
    for ( ; ! not( c ); c = cdr( c ) )
	{
	x = car( c );
	if ( lmin_chr_is( x ) )
	    {
	    twochar[0] = lmin_chr_get( x );
	    cp = twochar;
	    }
	else
	    cp = lmin_str_get( x );
	strcat( rstr, cp );
	}
    return r;
    }

static lmin_cellidx prim_string_find( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    const char* s1;
    char ch;
    const char* s2;
    const char* cp;
    s1 = lmin_str_get( val1 );
    if ( lmin_chr_is( val2 ) )
	{
	ch = lmin_chr_get( val2 );
	cp = strchr( s1, ch );
	}
    else if ( lmin_str_is( val2 ) )
	{
	s2 = lmin_str_get( val2 );
	cp = strstr( s1, s2 );
	}
    else
	return lmin_errex_err_make( "string_find: needle not a CHR or STR - \"%s\"", lmin_tocstring( val2 ) );
    if ( cp == (char*) 0 )
	return nil;
    return lmin_num_integer_make( (long) ( cp - s1 ) );
    }

static lmin_cellidx prim_vector( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c ), vals, last_val;
    size_t len = (size_t) lmin_num_integer_get( val );
    size_t i;
    lmin_cellidx r;
    last_val = nil;
    for ( vals = cdr( c ); lmin_cons_is( vals ); vals = cdr( vals ) )
	last_val = car( vals );
    r = lmin_vector_make( len, last_val );
    for ( i = 0, vals = cdr( c ); i < len && lmin_cons_is( vals ); ++i, vals = cdr( vals ) )
	lmin_vector_set( r, i, car( vals ) );
    return r;
    }

static lmin_cellidx prim_vector_length( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_num_integer_make( (long) lmin_vector_len_get( val ) );
    }

static lmin_cellidx prim_vector_length_set( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    lmin_vector_len_set( val1, (size_t) lmin_num_integer_get( val2 ) );
    return t;
    }

static lmin_cellidx prim_vector_get( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    long idx = lmin_num_integer_get( val2 );
    if ( idx < 0 )
	return lmin_errex_err_make( "vector_get: out of bounds" );
    return lmin_vector_get( val1, (size_t) idx );
    }

static lmin_cellidx prim_vector_set( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c ), val3 = lmin_third( c );
    long idx = lmin_num_integer_get( val2 );
    if ( idx < 0 )
	return lmin_errex_err_make( "vector_set: out of bounds" );
    return lmin_vector_set( val1, (size_t) idx, val3 );
    }

static lmin_cellidx prim_vector_fill_get( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_vector_fill_get( val );
    }

static lmin_cellidx prim_vector_fill_set( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    lmin_vector_fill_set( val1, val2 );
    return t;
    }

static lmin_cellidx prim_open( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val1 = lmin_first( c ), val2 = lmin_second( c );
    return lmin_stream_open( lmin_str_get( val1) , lmin_str_get( val2 ) );
    }

static lmin_cellidx prim_close( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    fclose( lmin_stream_get( val ) );
    return t;
    }

static lmin_cellidx prim_flush( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    fflush( lmin_stream_get( val ) );
    return t;
    }

static lmin_cellidx prim_err_make( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    return lmin_errex_err_str_make( lmin_first( c ) );
    }

#ifdef notdef
static void force_l( char* directive, size_t size )
    {
    size_t l = strlen( directive );
    if ( strchr( directive, 'l' ) != (char*) 0 )
	return;	/* already has an l */
    if ( l >= size - 1 )
	return;	/* no room to add an l */
    directive[l + 1] = '\0';
    directive[l] = directive[l - 1];
    directive[l - 1] = 'l';
    }

static lmin_cellidx vals_sprintf( lmin_cellidx vals )
    {
    lmin_cellidx format_str = car( vals ), params = cdr( vals ), param, r;
    const char* format = lmin_str_get( format_str );
    const char* cp;
    size_t dlen;
    char directive[1000], buf[1000];
    long in;
    double fl;
    char ch;
    const char* s;
    r = lmin_str_make( "" );

    /* Scan through format looking for formatting directives. */
    for ( cp = format; *cp != '\0'; ++cp )
	{
	if ( *cp == '%' )
	    {
	    /* Scan past all the modifiers and find the conversion specifier. */
	    dlen = strcspn( cp + 1, "diouxXDOUeEfFgGaACcSspn%" ) + 1;
	    /* Copy the directive. */
	    strncpy( directive, cp, dlen + 1 );
	    directive[dlen + 1] = '\0';
	    cp += dlen;
	    if ( *cp == '%' )
		strcpy( buf, "%" );
	    else
		{
		/* Get the parameter corresponding to this directive. */
		param = car( params );
		params = cdr( params );
		switch ( *cp )
		    {
		    case 'd': case 'i': case 'o': case 'u': case 'x': case 'X':
		    if ( ! lmin_num_integer_is( param ) )
			return lmin_errex_err_make( "not an integer NUM - \"%s\"", lmin_tocstring( param ) );
		    in = lmin_num_integer_get( param );
		    force_l( directive, sizeof(directive) );
		    snprintf( buf, sizeof(buf), directive, in );
		    break;
		    case 'e': case 'E': case 'f': case 'F': case 'g': case 'G':
		    if ( ! lmin_num_is( param ) )
			return lmin_errex_err_make( "not a NUM - \"%s\"", lmin_tocstring( param ) );
		    fl = lmin_num_float_get( param );
		    force_l( directive, sizeof(directive) );
		    snprintf( buf, sizeof(buf), directive, fl );
		    break;
		    case 'c':
		    if ( ! lmin_chr_is( param ) )
			return lmin_errex_err_make( "not a CHR - \"%s\"", lmin_tocstring( param ) );
		    ch = lmin_chr_get( param );
		    snprintf( buf, sizeof(buf), directive, ch );
		    break;
		    case 's':
		    if ( ! lmin_str_is( param ) )
			return lmin_errex_err_make( "not a STR - \"%s\"", lmin_tocstring( param ) );
		    s = lmin_str_get( param );
		    snprintf( buf, sizeof(buf), directive, s );
		    break;
		    }
		}
	    }
	else
	    {
	    buf[0] = *cp;
	    buf[1] = '\0';
	    }
	r = lmin_str_make2( lmin_str_get( r ), buf );
	}

    return r;
    }

static lmin_cellidx prim_sprintf( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    return vals_sprintf( c );
    }

static lmin_cellidx prim_fprintf( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx stream;
    stream = lmin_first( c );
    fputs( lmin_str_get( vals_sprintf( cdr( c ) ) ), lmin_stream_get( stream ) );
    return t;
    }

static lmin_cellidx prim_printf( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    fputs( lmin_str_get( vals_sprintf( c ) ), stdout );
    return t;
    }
#endif

/* Apply takes two args: a function to call, and a list of arguments
** to call it with:
**   (apply fun (arg1 arg2 arg3 ...))
** It rearranges things so the function and args are in the same list:
**   (fun arg1 arg2 arg3 ...)
** Then it evaluates that. So for example:
**   (apply + '(1 2 3))
** would return 6.
*/
static lmin_cellidx prim_apply( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx fun, args, call;
    fun = lmin_first( c );
    args = lmin_second( c );
    call = cons( fun, args );
    return lmin_eval( call, e );
    }

/* Funcall evaluates its argument list as if it was a function call.
** For example:
**   (funcall + 1 2 3)
** returns 6.
*/
static lmin_cellidx prim_funcall( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    return lmin_eval( c, e );
    }

static lmin_cellidx prim_boundp( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    return lmin_errex_is( assoc( val, env ) ) ? nil : t;
    }

static lmin_cellidx prim_throw( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx tag = nil, value = nil;
    if ( ! not( c ) )
	{
	if ( lmin_atom_is( car( c ) ) )
	    {
	    tag = car( c );
	    c = cdr( c );
	    }
	}
    if ( ! not( c ) )
	value = car( c );
    return lmin_errex_exception_make( tag, value );
    }

static void apropos_atom( lmin_cellidx key, lmin_cellidx datum )
    {
    FILE* fp = lmin_stream_get( lmin_stdout );
    const char* keystr;
    const char* typestr;
    keystr = lmin_atom_str_get( key );
    typestr = lmin_celltype_str( ct( datum ) );
    if ( lmin_atom_is( datum ) )
	fprintf( fp, "%s: %s %s\n", keystr, typestr, lmin_atom_str_get( datum ) );
    else if ( lmin_prim_is( datum ) )
	fprintf( fp, "%s: %s %s\n", keystr, typestr, lmin_tocstring( lmin_prim_vars_get( datum ) ) );
    else if ( lmin_closure_is( datum ) )
	fprintf( fp, "%s: %s %s\n", keystr, typestr, lmin_tocstring( lmin_closure_vars_get( datum ) ) );
    else if ( lmin_macro_is( datum ) )
	fprintf( fp, "%s: %s %s\n", keystr, typestr, lmin_tocstring( lmin_macro_vars_get( datum ) ) );
    else
	fprintf( fp, "%s: %s\n", keystr, typestr );
    }

static lmin_cellidx prim_apropos( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    lmin_cellidx al, key, datum;
    if ( lmin_atom_is( val ) )
	{
	datum = assoc( val, env );
	if ( lmin_errex_is( datum ) )
	    return datum;
	apropos_atom( val, datum );
	}
    else if ( lmin_str_is( val ) )
	{
	for ( al = env; lmin_cons_is( al ); al = cdr( al ) )
	    {
	    key = car( car( al ) );
	    if ( strcasestr( lmin_atom_str_get( key ), lmin_str_get( val ) ) != (char*) 0 )
		apropos_atom( key, cdr( car( al ) ) );
	    }
	}
    return t;
    }

static lmin_cellidx prim_apropos_list( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    lmin_cellidx val = lmin_first( c );
    const char* valstr = lmin_str_get( val );
    lmin_cellidx al, key, r;
    r = nil;
    for ( al = env; lmin_cons_is( al ); al = cdr( al ) )
	{
	key = car( car( al ) );
	if ( strcasestr( lmin_atom_str_get( key ), valstr ) != (char*) 0 )
	    r = cons( key, r );
	}
    return r;
    }

static lmin_cellidx prim_room( lmin_cellidx f, lmin_cellidx x, lmin_cellidx e )
    {
    unsigned int ninu, nfre, nastr, nsstr;
    lmin_atomidx a;
    lmin_cellidx c;
    size_t tot, sinu, sfre, sastr, ssstr;
    FILE* fp = lmin_stream_get( lmin_stdout );

    tot = atoms_size * sizeof(atom);
    ninu = 0;
    nastr = 0;
    sastr = 0;
    for ( a = atoms_inuse_list; a != EOL; a = atoms[a].next_idx )
	{
	++ninu;
	if ( atoms[a].external_str != (char*) 0 )
	    {
	    ++nastr;
	    sastr += strlen( atoms[a].external_str ) + 1;
	    }
	}
    nfre = 0;
    for ( a = atoms_free_list; a != EOL; a = atoms[a].next_idx )
	++nfre;
    sinu = ninu * sizeof(atom);
    sfre = nfre * sizeof(atom);
    fprintf( fp, "atoms: %ld bytes each, total %ld / %ldK, in use %d / %ldK, free %d / %ldK\n", sizeof(atom), atoms_size, tot / 1024, ninu, sinu / 1024, nfre, sfre / 1024 );

    tot = cells_size * sizeof(cell);
    ninu = 0;
    nsstr = 0;
    ssstr = 0;
    for ( c = cells_inuse_list; c != EOL; c = cells[c].next_idx )
	{
	++ninu;
	if ( ct( c ) == STR && lmin_str_get( c ) != (char*) 0 )
	    {
	    ++nsstr;
	    ssstr += lmin_str_len_get( c ) + 1;
	    }
	}
    nfre = 0;
    for ( c = cells_free_list; c != EOL; c = cells[c].next_idx )
	++nfre;
    sinu = ninu * sizeof(cell);
    sfre = nfre * sizeof(cell);
    fprintf( fp, "cells: %ld bytes each, total %ld / %ldK, in use %d / %ldK, free %d / %ldK\n", sizeof(cell), cells_size, tot / 1024, ninu, sinu / 1024, nfre, sfre / 1024 );
    fprintf( fp, "strings: ATOMs %d / %ldK, STRs %d / %ldK\n", nastr, sastr / 1024, nsstr, ssstr / 1024 );

    return t;
    }

static lmin_cellidx prim_census( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    FILE* fp = lmin_stream_get( lmin_stdout );
    int nnil = 0, natom = 0, ncons = 0, nprim = 0, nprimspecial = 0, nclosure = 0, nclosurespecial = 0, nmacro = 0, nnum = 0, ninteger = 0, nchr = 0, nstr = 0, nstream = 0, nvector = 0, ndata = 0, nerrex = 0, ntotal = 0, nperm = 0;
    lmin_cellidx al, x;
    for ( al = env; lmin_cons_is( al ); al = cdr( al ) )
	{
	x = cdr( car( al ) );
	switch ( ct( x ) )
	    {
	    case NIL: ++nnil; break;
	    case ATOM: ++natom; break;
	    case CONS:
	    ++ncons;
	    break;
	    case PRIM:
	    ++nprim;
	    if ( cell_special_is( x ) )
		++nprimspecial;
	    break;
	    case CLOSURE:
	    ++nclosure;
	    if ( cell_special_is( x ) )
		++nclosurespecial;
	    break;
	    case MACRO:
	    ++nmacro;
	    break;
	    case NUM:
	    ++nnum;
	    if ( cell_integer_is( x ) )
		++ninteger;
	    break;
	    case CHR: ++nchr; break;
	    case STR: ++nstr; break;
	    case STREAM: ++nstream; break;
	    case VECTOR: ++nvector; break;
	    case DATA: ++ndata; break;
	    case ERREX: ++nerrex; break;
	    }
	++ntotal;
	if ( cell_permanent_is( x ) )
	    ++nperm;
	}
    fprintf( fp, "Current contents of the global environment by type:\n" );
    if ( nnil > 0 )
	fprintf( fp, "  NIL:         %d\n", nnil );
    if ( natom > 0 )
	fprintf( fp, "  ATOM:        %d\n", natom );
    if ( ncons > 0 )
	fprintf( fp, "  CONS:        %d\n", ncons );
    if ( nprim > 0 )
	{
	fprintf( fp, "  PRIM:        %d\n", nprim );
	if ( nprimspecial > 0 )
	    fprintf( fp, "    special:     %d\n", nprimspecial );
	}
    if ( nclosure > 0 )
	{
	fprintf( fp, "  CLOSURE:     %d\n", nclosure );
	if ( nclosurespecial > 0 )
	    fprintf( fp, "    special:   %d\n", nclosurespecial );
	}
    if ( nmacro > 0 )
	fprintf( fp, "  MACRO:       %d\n", nmacro );
    if ( nnum > 0 )
	{
	fprintf( fp, "  NUM:         %d\n", nnum );
	if ( ninteger > 0 )
	    fprintf( fp, "    integer:     %d\n", ninteger );
	}
    if ( nchr > 0 )
	fprintf( fp, "  CHR:         %d\n", nchr );
    if ( nstr > 0 )
	fprintf( fp, "  STR:         %d\n", nstr );
    if ( nstream > 0 )
	fprintf( fp, "  STREAM:      %d\n", nstream );
    if ( nvector > 0 )
	fprintf( fp, "  VECTOR:      %d\n", nvector );
    if ( ndata > 0 )
	fprintf( fp, "  DATA:        %d\n", ndata );
    if ( nerrex > 0 )
	fprintf( fp, "  ERREX:       %d\n", nerrex );
    if ( ntotal > 0 )
	fprintf( fp, "  total:       %d\n", ntotal );
    if ( nperm > 0 )
	fprintf( fp, "  permed:      %d\n", nperm );
    return t;
    }

static lmin_cellidx prim_celldump( lmin_cellidx f, lmin_cellidx c, lmin_cellidx e )
    {
    c = eval( car( c ), e );
    celldump( c );
    return t;
    }


/* Public liblmin routines */

/* Initialize the lmin package. */
void lmin_init( void )
    {
    atoms_init();
    cells_init();
    typecheck_init();
    read_init();

    /* Make some basic objects. */
    lmin_nil = nil = lmin_perm( cell_make( NIL ) );
    lmin_t = t = lmin_perm( lmin_atom_make( "t" ) );
    env = acons( t, t, nil );
    callstack = nil;
    lmin_err_incomplete = lmin_perm( lmin_errex_err_make( "incomplete expression" ) );
    lmin_err_eof = lmin_perm( lmin_errex_err_make( "EOF" ) );

    /* Add some defines: nan, floating point infinity, stdin/stdout/stderr. */
    lmin_define( lmin_atom_make( "nan" ), lmin_num_float_make( NAN ) );
    lmin_define( lmin_atom_make( "inf" ), lmin_num_float_make( HUGE_VAL ) );
    lmin_stdin = lmin_stream_make( stdin );
    lmin_define( lmin_atom_make( "stdin" ), lmin_stdin );
    lmin_stdout = lmin_stream_make( stdout );
    lmin_define( lmin_atom_make( "stdout" ), lmin_stdout );
    lmin_stderr = lmin_stream_make( stderr );
    lmin_define( lmin_atom_make( "stderr" ), lmin_stderr );

    /* Add primitives. First the special forms. */
    env = prim_make( "quote", prim_quote, "(c)", env, true );
    env = prim_make( "define", prim_define, "(\"atom\" name val)", env, true );
    env = prim_make( "lambda", prim_lambda, "(\"list\" vars body)", env, true );
    env = prim_make( "macro", prim_macro, "(\"list\" vars body)", env, true );
    env = prim_make( "or", prim_or, "(\"any+\")", env, true );
    env = prim_make( "and", prim_and, "(\"any+\")", env, true );
    env = prim_make( "cond", prim_cond, "()", env, true );
    env = prim_make( "if", prim_if, "(\"any\" p \"any\" y \"any?\" f)", env, true );
    env = prim_make( "let*", prim_leta, "()", env, true );
    env = prim_make( "let", prim_let, "()", env, true );
    env = prim_make( "letrec", prim_letrec, "()", env, true );
    env = prim_make( "progn", prim_progn, "()", env, true );
    env = prim_make( "while", prim_while, "(\"any+\")", env, true );
    env = prim_make( "until", prim_until, "()", env, true );
    env = prim_make( "catch", prim_catch, "()", env, true );
    env = prim_make( "setq!", prim_setq, "(\"atom\" a c)", env, true );
    env = prim_make( "permq", prim_permq, "(c)", env, true );
    env = prim_make( "errex?", prim_errexp, "(c)", env, true );
    env = prim_make( "time", prim_time, "()", env, true );

    /* And now the regular forms. */
    env = prim_make( "cons", prim_cons, "(ar dr)", env, false );
    env = prim_make( "car", prim_car, "(\"cons\" c)", env, false );
    env = prim_make( "cdr", prim_cdr, "(\"cons\" c)", env, false );
    env = prim_make( "eval", prim_eval, "(c)", env, false );
    env = prim_make( "+", prim_add, "(\"number*\")", env, false );
    env = prim_make( "-", prim_subtract, "(\"number+\")", env, false );
    env = prim_make( "*", prim_multiply, "(\"number*\")", env, false );
    env = prim_make( "/", prim_divide, "(\"number+\")", env, false );
    env = prim_make( "truncate", prim_truncate, "(\"number\" x)", env, false );
    env = prim_make( "floor", prim_floor, "(\"number\" x)", env, false );
    env = prim_make( "<", prim_lt, "(\"atom|number|character|string\" a \"atom|number|character|string\" b)", env, false );
    env = prim_make( "ash", prim_ash, "(\"integer\" n \"integer\" m)", env, false );
    env = prim_make( "sqrt", prim_sqrt, "(\"number\" x)", env, false );
    env = prim_make( "expt", prim_expt, "(\"number\" x \"number\" y)", env, false );
    env = prim_make( "sin", prim_sin, "(\"number\" x)", env, false );
    env = prim_make( "cos", prim_cos, "(\"number\" x)", env, false );
    env = prim_make( "tan", prim_tan, "(\"number\" x)", env, false );
    env = prim_make( "exp", prim_exp, "(\"number\" x)", env, false );
    env = prim_make( "log", prim_log, "(\"number\" x)", env, false );
    env = prim_make( "asin", prim_asin, "(\"number\" x)", env, false );
    env = prim_make( "acos", prim_acos, "(\"number\" x)", env, false );
    env = prim_make( "atan", prim_atan, "(\"number\" x)", env, false );
    env = prim_make( "eq?", prim_eq, "(x y)", env, false );
    env = prim_make( "eql?", prim_eql, "(x y)", env, false );
    env = prim_make( "atom?", prim_atomp, "(c)", env, false );
    env = prim_make( "cons?", prim_consp, "(c)", env, false );
    env = prim_make( "closure?", prim_closurep, "(c)", env, false );
    env = prim_make( "macro?", prim_macrop, "(c)", env, false );
    env = prim_make( "prim?", prim_primp, "(c)", env, false );
    env = prim_make( "number?", prim_numberp, "(c)", env, false );
    env = prim_make( "integer?", prim_integerp, "(c)", env, false );
    env = prim_make( "character?", prim_characterp, "(c)", env, false );
    env = prim_make( "string?", prim_stringp, "(c)", env, false );
    env = prim_make( "stream?", prim_streamp, "(c)", env, false );
    env = prim_make( "vector?", prim_vectorp, "(c)", env, false );
    env = prim_make( "data?", prim_datap, "(c)", env, false );
    env = prim_make( "not", prim_not, "(c)", env, false );
    env = prim_make( "assoc", prim_assoc, "(\"atom\" key alist)", env, false );
    env = prim_make( "rplaca", prim_rplaca, "(\"cons\" c ar)", env, false );
    env = prim_make( "rplacd", prim_rplacd, "(\"cons\" c dr)", env, false );
    env = prim_make( "write", prim_write, "(c \"stream?\" s)", env, false );
    env = prim_make( "write-string", prim_write_string, "(\"string\" c \"stream?\" s)", env, false );
    env = prim_make( "read", prim_read, "(\"stream?\" s)", env, false );
    env = prim_make( "read-char", prim_read_char, "(\"stream?\" s)", env, false );
    env = prim_make( "read-line", prim_read_line, "(\"stream?\" s)", env, false );
    env = prim_make( "env", prim_env, "()", env, false );
    env = prim_make( "callstack", prim_callstack, "()", env, false );
    env = prim_make( "usleep", prim_usleep, "(\"integer\" n)", env, false );
    env = prim_make( "random", prim_random, "(\"integer?\" n)", env, false );
    env = prim_make( "parse-integer", prim_parse_integer, "(\"string\" s)", env, false );
    env = prim_make( "chr", prim_chr, "(\"integer\" n)", env, false );
    env = prim_make( "chrnum", prim_chrnum, "(\"character\" ch)", env, false );
    env = prim_make( "chr-tolower", prim_chr_tolower, "(\"character\" c)", env, false );
    env = prim_make( "chr-toupper", prim_chr_toupper, "(\"character\" c)", env, false );
    env = prim_make( "chr-isspace", prim_chr_isspace, "(\"character\" c)", env, false );
    env = prim_make( "string", prim_string, "(c)", env, false );
    env = prim_make( "string-length", prim_string_length, "(\"string|character\" s)", env, false );
    env = prim_make( "string-chrat", prim_string_chrat, "(\"string\" s \"integer\" pos)", env, false );
    env = prim_make( "string-substr", prim_string_substr, "(\"string\" s \"integer\" pos \"integer?\" len)", env, false );
    env = prim_make( "string-concat", prim_string_concat, "(\"string|character*\" s)", env, false );
    env = prim_make( "string-find", prim_string_find, "(\"string\" haystack \"string|character\" needle)", env, false );
    env = prim_make( "vector", prim_vector, "(\"integer\" len)", env, false );
    env = prim_make( "vector-length", prim_vector_length, "(\"vector\" v)", env, false );
    env = prim_make( "vector-length-set!", prim_vector_length_set, "(\"vector\" v \"integer\" len)", env, false );
    env = prim_make( "vector-get", prim_vector_get, "(\"vector\" v \"integer\" i)", env, false );
    env = prim_make( "vector-set!", prim_vector_set, "(\"vector\" v \"integer\" i \"any\" val)", env, false );
    env = prim_make( "vector-fill-get", prim_vector_fill_get, "(\"vector\" v)", env, false );
    env = prim_make( "vector-fill-set!", prim_vector_fill_set, "(\"vector\" v \"any\" fill)", env, false );
    env = prim_make( "open", prim_open, "(\"string\" path \"string\" mode)", env, false );
    env = prim_make( "close", prim_close, "(\"stream\" s)", env, false );
    env = prim_make( "flush", prim_flush, "(\"stream\" s)", env, false );
    env = prim_make( "err-make", prim_err_make, "(\"string\" format)", env, false );
#ifdef notdef
    env = prim_make( "sprintf", prim_sprintf, "(\"string\" format)", env, false );
    env = prim_make( "fprintf", prim_fprintf, "(\"stream\" s \"string\" format)", env, false );
    env = prim_make( "printf", prim_printf, "(\"string\" format)", env, false );
#endif
    env = prim_make( "apply", prim_apply, "(\"function\" fun \"list\" args)", env, false );
    env = prim_make( "funcall", prim_funcall, "(\"function\" fun)", env, false );
    env = prim_make( "bound?", prim_boundp, "(\"atom\" a)", env, false );
    env = prim_make( "throw", prim_throw, "()", env, false );
    env = prim_make( "apropos", prim_apropos, "(\"atom|string\" c)", env, false );
    env = prim_make( "apropos-list", prim_apropos_list, "(\"string\" c)", env, false );
    env = prim_make( "room", prim_room, "()", env, false );
    env = prim_make( "census", prim_census, "()", env, false );
    env = prim_make( "celldump", prim_celldump, "(c)", env, false );

    /* Add add-ons. */
    load_addons();

#ifdef CHECKS
    /* Consistency check. */
    atoms_check();
    cells_check();
#endif /* CHECKS */
    }


/* Terminate lmin, when your program exits. */
void lmin_term( void )
    {
    atoms_term();
    cells_term();
    typecheck_term();
    read_term();
    }


/* Parse a string into an lmin expression. */

static lmin_cellidx parse( const char** cpP );

static void skip_whitespace( const char** cpP )
    {
    for (;;)
	{
	if ( isspace( **cpP ) )
	    ++*cpP;
	else if ( **cpP == ';' )
	    do
		++*cpP;
	    while ( **cpP != '\n' && **cpP != '\0' );
	else
	    return;
	}
    }

static lmin_cellidx parse_list( const char** cpP )
    {
    lmin_cellidx c, c2;

    /* Is it the end of the list? */
    skip_whitespace( cpP );
    if ( **cpP == ')' )
	{
	++*cpP;	/* skip close paren */
	return nil;
	}

    /* Is it a dot? */
    skip_whitespace( cpP );
    if ( **cpP == '.' && isspace( *(*cpP + 1) ) )
	{
	/* A dot means there is exactly one more subexpression. */
	++*cpP;	/* skip dot */
	c = parse( cpP );
	if ( lmin_errex_is( c ) )
	    return c;
	skip_whitespace( cpP );
	if ( **cpP != ')' )
	    return lmin_errex_err_make( "expected close paren, got '%c'", **cpP );
	++*cpP;	/* skip close paren */
	return c;
	}

    /* Parse the first subexpression. */
    c = parse( cpP );
    if ( lmin_errex_is( c ) )
	return c;

    /* Recurse for more subexpressions. */
    c2 = parse_list( cpP );
    if ( lmin_errex_is( c2 ) )
	return c2;

    /* And put them together. */
    return cons( c, c2 );
    }

static lmin_cellidx parse_vector( const char** cpP )
    {
    lmin_cellidx c, c2;

    /* Is it the end of the vector? */
    skip_whitespace( cpP );
    if ( **cpP == ']' )
	{
	++*cpP;	/* skip close square bracket */
	return nil;
	}

    /* Parse the first subexpression. */
    c = parse( cpP );
    if ( lmin_errex_is( c ) )
	return c;

    /* Recurse for more subexpressions. */
    c2 = parse_vector( cpP );
    if ( lmin_errex_is( c2 ) )
	return c2;

    /* And put them together. */
    return cons( c, c2 );
    }

static lmin_cellidx parse_squote( const char** cpP )
    {
    lmin_cellidx c;

    ++*cpP;	/* skip single quote */
    if ( **cpP == '\\' && *(*cpP+1) != '\0' && *(*cpP+2) == '\'' )
	{
	/* Escaped character literal. */
	char ch = *(*cpP+1);
	switch ( ch )
	    {
	    case 't': ch = '\t'; break;
	    case 'n': ch = '\n'; break;
	    case 'r': ch = '\r'; break;
	    }
	c = lmin_chr_make( ch );
	*cpP += 3;
	return c;
	}
    if ( **cpP != '\0' && *(*cpP+1) == '\'' )
	{
	/* We have '.' but if the . is a ( it could still be a quoted
	** list where the first item is a character literal. Like this:
	**   '('a' 'b')
	** Look ahead a little more to sure it's a charlit, or fall
	** through to the quoted list case.
	*/
	if ( **cpP != '(' || *(*cpP+2) == '\0' || *(*cpP+3) != '\'' )
	    {
	    /* Character literal. */
	    c = lmin_chr_make( **cpP );
	    *cpP += 2;
	    return c;
	    }
	}
    /* Quoted list. */
    c = parse( cpP );
    if ( lmin_errex_is( c ) )
	return c;
    return cons( lmin_atom_make( "quote" ), cons( c, nil ) );
    }

static lmin_cellidx parse_dquote( const char** cpP )
    {
    const char* start;
    lmin_cellidx c;
    char* s;

    /* Skip double quote. */
    ++*cpP;

    /* Step forward until a non-escaped double quote. */
    start = *cpP;
    for (;;)
	{
	switch ( **cpP )
	    {
	    case '\0':
	    return lmin_errex_err_make( "string literal is missing closing double quote" );

	    break;
	    case '\\':
	    ++*cpP;
	    if ( **cpP == '\0' )
		return lmin_errex_err_make( "string literal is missing closing double quote" );
	    break;
	    case '"':
	    /* Found the end of the literal. Make the string! */
	    c = lmin_str_makel( start, (size_t) ( *cpP - start ) );
	    /* Skip over the closing quote. */
	    ++*cpP;
	    /* Do backslash escapes. */
	    for ( s = (char*) lmin_str_get( c ); *s != '\0'; ++s )
		{
		if ( *s == '\\' )
		    {
		    /* Shift the rest of the string down one position.
		    ** The only byte move routine guaranteed to work
		    ** on overlapping areas is memmove(3).
		    */
		    memmove( s, s + 1, lmin_str_len_get( c ) - (size_t) ( s - lmin_str_get( c ) ) );
		    --cells[c].u.str.len;
		    /* Transform some characters. */
		    switch ( *s )
			{
			case 't': *s = '\t'; break;
			case 'n': *s = '\n'; break;
			case 'r': *s = '\r'; break;
			}
		    }
		}
	    return c;
	    }
	++*cpP;
	}
    }

static lmin_cellidx parse_atomish( const char** cpP )
    {
    size_t wordlen, copylen;
    char word[10000];

    skip_whitespace( cpP );
    wordlen = strcspn( *cpP, " \t\n()[];" );
    copylen = min( wordlen, sizeof(word) - 1 );
    strncpy( word, *cpP, copylen );
    word[copylen] = '\0';
    *cpP += wordlen;
    wordlen = strlen( word );
    if ( strchr( "0123456789+-.", word[0] ) != (char*) 0 &&
	 ! ( ( word[0] == '+' || word[0] == '-' || word[0] == '.' ) && word[1] == '\0' ) )
	{
	/* Numeric. */
	char* endptr;
	if ( word[0] == '0' && tolower( word[1] ) == 'x' )
	    {
	    /* Hex. */
	    long h = (long) strtol( &word[2], &endptr, 16 );
	    if ( *endptr != '\0' )
		return lmin_errex_err_make( "malformed hex number - \"%s\"", word );
	    return lmin_num_integer_make( h );
	    }
	else if ( strcspn( word, ".e" ) == wordlen )
	    {
	    /* Long. */
	    long in = strtol( word, &endptr, 10 );
	    if ( *endptr != '\0' )
		return lmin_errex_err_make( "malformed integer - \"%s\"", word );
	    return lmin_num_integer_make( in );
	    }
	else
	    {
	    /* Float. */
	    double fl = strtod( word, &endptr );
	    if ( *endptr != '\0' )
		return lmin_errex_err_make( "malformed float - \"%s\"", word );
	    return lmin_num_float_make( fl );
	    }
	}
    else
	{
	/* Atom. */
	if ( word[0] == '.' && word[1] == '\0' )
	    return lmin_errex_err_make( "illegal symbol - \"%s\"", word );
	return lmin_atom_make( word );
	}
    }

static lmin_cellidx parse( const char** cpP )
    {
    skip_whitespace( cpP );
    if ( **cpP == '\0' )
	return lmin_err_incomplete;
    else if ( **cpP == ')' )
	return lmin_errex_err_make( "unexpected close paren" );
    else if ( **cpP == '(' )
	{
	++*cpP;	/* skip open paren */
	skip_whitespace( cpP );
	if ( **cpP == '.' && isspace( *(*cpP + 1) ) )
	    return lmin_errex_err_make( "dot at the start of a list" );
	return parse_list( cpP );
	}
    else if ( **cpP == ']' )
	return lmin_errex_err_make( "unexpected close square bracket" );
    else if ( **cpP == '[' )
	{
	lmin_cellidx vl, v;
	size_t i;
	++*cpP;	/* skip open square bracket */
	vl = parse_vector( cpP );
	if ( lmin_errex_is( vl ) )
	    return vl;
	/* parse_vector returns a list, not a vector, so we convert it. */
	v = lmin_vector_make( lmin_list_length( vl ), nil );
	for ( i = 0; lmin_cons_is( vl ); ++i, vl = cdr( vl ) )
	    lmin_vector_set( v, i, car( vl ) );
	return v;
	}
    else if ( **cpP == '\'' )
	return parse_squote( cpP );
    else if ( **cpP == '"' )
	return parse_dquote( cpP );
    else
	return parse_atomish( cpP );
    }

lmin_cellidx lmin_parse( const char* str )
    {
    const char* cp = str;
    lmin_cellidx r;

    r = parse( &cp );
    skip_whitespace( &cp );
    if ( ! lmin_errex_is( r ) && *cp != '\0' )
	r = lmin_errex_err_make( "extra characters after valid expression - \"%s\"", cp );
    return r;
    }


/* Make a global definition. */
lmin_cellidx lmin_define( lmin_cellidx var, lmin_cellidx val )
    {
    if ( ! lmin_atom_is( var ) )
	return lmin_errex_err_make( "lmin_define: not an ATOM - \"%s\"", lmin_tocstring( var ) );
    env = acons( var, val, env );
    return var;
    }


/* Evaluate an lmin expression. If the evaluation environment e is 
** nil, the global environment is used.
*/
lmin_cellidx lmin_eval( lmin_cellidx c, lmin_cellidx e )
    {
    return eval( c, not( e ) ? env : e );
    }


/* Evaluate an argument list. Usually the first thing done by a C
** primitive function.
*/
lmin_cellidx lmin_eval_args( lmin_cellidx c, lmin_cellidx e )
    {
    if ( lmin_atom_is( c ) )
	return assoc( c, e );
    else if ( lmin_cons_is( c ) )
	return cons( eval( car( c ), e ), lmin_eval_args( cdr( c ), e ) );
    else
	return nil;
    }


static void backslashify( char c, FILE* fp, lmin_celltype typ )
    {
    switch ( c )
	{
	case '\t': fputs( "\\t", fp ); break;
	case '\n': fputs( "\\n", fp ); break;
	case '\r': fputs( "\\r", fp ); break;
	case '\'': fputs( typ == CHR ? "\\'" : "'", fp ); break;
	case '"': fputs( typ == STR ? "\\\"" : "\"", fp ); break;
	default: fputc( c, fp ); break;
	}
    }

/* Write an lmin expression to a file pointer. */
void lmin_write( lmin_cellidx c, FILE* fp )
    {
    const char* cp;
    size_t i;
    lmin_celltype typ = ct( c );
    switch ( typ )
	{
	case NIL:
	fprintf( fp, "()" );
	break;
	case ATOM:
	fprintf( fp, "%s", lmin_atom_str_get( c ) );
	break;
	case CONS:
	fputc( '(', fp );
	for (;;)
	    {
	    lmin_write( car( c ), fp );
	    c = cdr( c );
	    if ( not( c ) )
		break;
	    if ( ! lmin_cons_is( c ) )
		{
		fprintf( fp, " . " );
		lmin_write( c, fp );
		break;
		}
	    else
		fputc( ' ', fp );
	    }
	fputc( ')', fp );
	break;
	case PRIM:
	fprintf( fp, "[PRIM %#lx %s]", (unsigned long) lmin_prim_fp_get( c ), lmin_tocstring( lmin_prim_vars_get( c ) ) );
	break;
	case CLOSURE:
	fprintf( fp, "(lambda " );
	lmin_write( lmin_closure_vars_get( c ), fp );
	fputc( ' ', fp );
	lmin_write( lmin_closure_body_get( c ), fp );
	fputc( ')', fp );
	break;
	case MACRO:
	fprintf( fp, "(macro " );
	lmin_write( lmin_closure_vars_get( c ), fp );
	fputc( ' ', fp );
	lmin_write( lmin_closure_body_get( c ), fp );
	fputc( ')', fp );
	break;
	case NUM:
	if ( cell_integer_is( c ) )
	    fprintf( fp, "%ld", lmin_num_integer_get( c ) );
	else
	    fprintf( fp, "%g", lmin_num_float_get( c ) );
	break;
	case CHR:
	fputc( '\'', fp );
	backslashify( lmin_chr_get( c ), fp, typ );
	fputc( '\'', fp );
	break;
	case STR:
	fputc( '"', fp );
	for ( cp = lmin_str_get( c ); *cp != '\0'; ++cp )
	    backslashify( *cp, fp, typ );
	fputc( '"', fp );
	break;
	case STREAM:
	fprintf( fp, "[STREAM %p]", (void*) lmin_stream_get( c ) );
	break;
	case VECTOR:
	fputc( '[', fp );
	for ( i = 0; i < lmin_vector_len_get( c ); ++i )
	    {
	    if ( i > 0 )
		fputc( ' ', fp );
	    lmin_write( lmin_vector_get( c, i ), fp );
	    }
	fputc( ']', fp );
	break;
	case DATA:
	fprintf( fp, "[DATA %p]", lmin_data_ptr_get( c ) );
	break;
	case ERREX:
	if ( lmin_errex_err_is( c ) )
	    fprintf( fp, "error %s", lmin_errex_err_str_get( c ) );
	else if ( lmin_errex_exception_is( c ) )
	    fprintf( fp, "exception %s", lmin_tocstring( lmin_errex_payload_get( c ) ) );
	else
	    fprintf( fp, "ERREX %s", lmin_tocstring( lmin_errex_payload_get( c ) ) );
	break;
	}
    }

void lmin_write_line( lmin_cellidx c, FILE* fp )
    {
    lmin_write( c, fp );
    fputc( '\n', fp );
    }

/* Read an lmin expression from a file pointer. */
static char* srcbuf;
static size_t srcbuf_size;
lmin_cellidx lmin_read( FILE* fp, int* linesP )
    {
    bool got_something;
    char linebuf[1000];
    size_t needed_size;
    char* cp;
    lmin_cellidx r;

    srcbuf[0] = '\0';
    got_something = false;
    if ( linesP != (int*) 0 )
	*linesP = 0;
    for (;;)
	{
	if ( isatty( fileno( fp ) ) )
	    {
	    if ( ! got_something )
		printf( "> " );
	    else
		printf( ">> " );
	    }
	if ( fgets( linebuf, sizeof(linebuf), fp ) == (char*) 0 )
	    {
	    if ( got_something )
		return lmin_err_incomplete;
	    else
		return lmin_err_eof;
	    }
	if ( linesP != (int*) 0 )
	    ++*linesP;

	needed_size = strlen( srcbuf ) + strlen( linebuf ) + 1;
	if ( needed_size > srcbuf_size )
	    {
	    srcbuf_size = needed_size * 2;
	    srcbuf = (char*) REALLOC( (void*) srcbuf, srcbuf_size );
	    if ( srcbuf == (char*) 0 )
		{
		fprintf( stderr, "lmin: out of memory\n" );
		return EX_SOFTWARE;
		}
	    }

	/* Add line to src. */
	strcat( srcbuf, linebuf );

	/* Is this line blank? */
	cp = linebuf + strspn( linebuf, " \t\r\n" );
	if ( *cp == '\0' || *cp == ';' )
	    continue;
	got_something = true;

	/* Do we have a complete expression, or some other error? */
	r = lmin_parse( srcbuf );
	if ( r != lmin_err_incomplete )
	    return r;
	/* Collect any garbage from parsing the incomplete expression. */
	lmin_gc();
	}
    }

static void read_init( void )
    {
    srcbuf_size = 1000;
    srcbuf = (char*) MALLOC( srcbuf_size );
    if ( srcbuf == (char*) 0 )
	{
	fprintf( stderr, "lmin: out of memory\n" );
	exit( EX_SOFTWARE );
	}
    }

static void read_term( void )
    {
    FREE( srcbuf );
    }

void lmin_show_errex( FILE* fp, const char* filename, int linenum, lmin_cellidx errex )
    {
    const size_t errstack_lim = 16;
    size_t errstack_len, i;
    lmin_cellidx payload = lmin_errex_payload_get( errex );
    lmin_cellidx errstack = lmin_errex_callstack_get( errex );
    if ( fp == (FILE*) 0 || ! isatty( fileno( fp ) ) )
	{
	fprintf( stderr, "%s ", filename );
	if ( linenum > 0 )
	    fprintf( stderr, "%d ", linenum );
	fprintf( stderr, "- " );
	}
    if ( lmin_errex_err_is( errex ) )
	fprintf( stderr, "error: %s\n", lmin_errex_err_str_get( errex ) );
    else if ( lmin_errex_exception_is( errex ) )
	fprintf( stderr, "uncaught exception: tag %s, value %s\n", lmin_tocstring( lmin_errex_exception_tag_get( errex ) ), lmin_tocstring( lmin_errex_exception_value_get( errex ) ) );
    else
	fprintf( stderr, "unknown error payload: %s\n", lmin_tocstring( payload ) );
    /* Show stack. */
    errstack_len = lmin_list_length( errstack );
    if ( errstack_len > 0 )
	{
	fprintf( stderr, "call stack:" );
	for ( i = 0; lmin_cons_is( errstack ); ++i, errstack = cdr( errstack ) )
	    {
	    if ( errstack_len > errstack_lim + 1 && i == errstack_lim / 2 )
		fprintf( stderr, " [...]" );
	    if ( errstack_len <= errstack_lim + 1 || i < errstack_lim / 2 || i >= errstack_len - errstack_lim / 2 )
		fprintf( stderr, " %s", lmin_tocstring( car( errstack ) ) );
	    }
	fprintf( stderr, "\n" );
	}
    }


/* Garbage collection. This is guaranteed to not make any new data
** structures, so it's safe to call when the atom or cell table fills up.
*/

static void lmin_mark_traverse( lmin_cellidx c )
    {
    size_t i;

    /* Avoid infinite recursion on circular structures. */
    if ( cell_marked_is( c ) )
	return;

    /* Mark this cell. */
    cell_marked_set(c);

    /* Mark all atoms and cells reachable from it. */
    switch ( ct( c ) )
	{
	case ATOM:
	atom_marked_set( lmin_atom_idx_get( c ) );
	break;
	case CONS:
	lmin_mark_traverse( car( c ) );
	lmin_mark_traverse( cdr( c ) );
	break;
	case PRIM:
	lmin_mark_traverse( lmin_prim_vars_get( c ) );
	break;
	case CLOSURE:
	lmin_mark_traverse( lmin_closure_vars_get( c ) );
	lmin_mark_traverse( lmin_closure_body_get( c ) );
	lmin_mark_traverse( lmin_closure_defenv_get( c ) );
	break;
	case MACRO:
	lmin_mark_traverse( lmin_macro_vars_get( c ) );
	lmin_mark_traverse( lmin_macro_body_get( c ) );
	break;
	case VECTOR:
	for ( i = 0; i < lmin_vector_len_get( c ); ++i )
	    lmin_mark_traverse( lmin_vector_get( c, i ) );
	lmin_mark_traverse( cells[c].u.vec.fill );
	break;
	case ERREX:
	lmin_mark_traverse( lmin_errex_payload_get( c ) );
	lmin_mark_traverse( lmin_errex_callstack_get( c ) );
	break;
	default:
	break;
	}
    }

void lmin_gc( void )
    {
    lmin_cellidx c;
    int cells_freed, atoms_freed;

    /* Unmark everything active. */
    cells_unmark_all();
    atoms_unmark_all();

    /* Mark and traverse the global environment. */
    lmin_mark_traverse( env );

    /* Mark and traverse any active permanent cells. */
    c = cells_inuse_list;
    while ( c != EOL )
	{
	if ( cell_permanent_is( c ) )
	    lmin_mark_traverse( c );
	c = cells[c].next_idx;
	}

    /* Delete anything that's not marked. */
    cells_freed = cells_del_unmarked();
    atoms_freed = atoms_del_unmarked();

#ifdef CHECKS
    /* Consistency check. */
    atoms_check();
    cells_check();
#endif /* CHECKS */
    }

lmin_cellidx lmin_perm( lmin_cellidx c )
    {
    cell_permanent_set( c );
    return c;
    }

lmin_celltype lmin_cell_type_get( lmin_cellidx c )
    {
    return cells[c].typ;
    }

const char* lmin_celltype_str( lmin_celltype typ )
    {
    switch ( typ )
	{
	case NIL: return "NIL";
	case ATOM: return "ATOM";
	case CONS: return "CONS";
	case PRIM: return "PRIM";
	case CLOSURE: return "CLOSURE";
	case MACRO: return "MACRO";
	case NUM: return "NUM";
	case CHR: return "CHR";
	case STR: return "STR";
	case STREAM: return "STREAM";
	case VECTOR: return "VECTOR";
	case DATA: return "DATA";
	case ERREX: return "ERREX";
	default: return "???";
	}
    }


/* Each cell type has a maker, a predicate, and a getter. Sometimes
** more than one.
*/

/* NIL */

bool lmin_nil_is( lmin_cellidx c )
    {
    return ct( c ) == NIL;
    }

/* ATOM */

lmin_cellidx lmin_atom_make( const char* str )
    {
    lmin_cellidx c = cell_make( ATOM );
    cells[c].u.atom.idx = atom_intern( str );
    return c;
    }
bool lmin_atom_is( lmin_cellidx c )
    {
    return ct( c ) == ATOM;
    }
lmin_atomidx lmin_atom_idx_get( lmin_cellidx c )
    {
    if ( lmin_atom_is( c ) )
	return cells[c].u.atom.idx;
    else
	return EOL;
    }
const char* lmin_atom_str_get( lmin_cellidx c )
    {
    return atom_str_get( lmin_atom_idx_get( c ) );
    }

/* CONS */

lmin_cellidx lmin_cons_make( lmin_cellidx ar, lmin_cellidx dr )
    {
    lmin_cellidx c = cell_make( CONS );
    cells[c].u.cns.ar = ar;
    cells[c].u.cns.dr = dr;
    return c;
    }
bool lmin_cons_is( lmin_cellidx c )
    {
    return ct( c ) == CONS;
    }
lmin_cellidx lmin_cons_car_get( lmin_cellidx c )
    {
    /* Return the car of a CONS or error if not a CONS. */
    if ( ! lmin_cons_is( c ) )
	return lmin_errex_err_make( "not a CONS - \"%s\"", lmin_tocstring( c ) );
    return cells[c].u.cns.ar;
    }
lmin_cellidx lmin_cons_cdr_get( lmin_cellidx c )
    {
    /* Return the cdr of a CONS or error if not a CONS. */
    if ( ! lmin_cons_is( c ) )
	return lmin_errex_err_make( "not a CONS - \"%s\"", lmin_tocstring( c ) );
    return cells[c].u.cns.dr;
    }
lmin_cellidx lmin_cons_car_set( lmin_cellidx c, lmin_cellidx ar )
    {
    /* Change the car of a CONS, returns error if not a CONS. */
    if ( ! lmin_cons_is( c ) )
	return lmin_errex_err_make( "not a CONS - \"%s\"", lmin_tocstring( c ) );
    cells[c].u.cns.ar = ar;
    return c;
    }
lmin_cellidx lmin_cons_cdr_set( lmin_cellidx c, lmin_cellidx dr)
    {
    /* Change the cdr of a CONS, returns error if not a CONS. */
    if ( ! lmin_cons_is( c ) )
	return lmin_errex_err_make( "not a CONS - \"%s\"", lmin_tocstring( c ) );
    cells[c].u.cns.dr = dr;
    return c;
    }

/* PRIM */

void lmin_prim_make( const char* name, lmin_prim_fp fp, const char* vars, bool special )
    {
    env = prim_make( name, fp, vars, env, special );
    }
bool lmin_prim_is( lmin_cellidx c )
    {
    return ct( c ) == PRIM;
    }
lmin_prim_fp lmin_prim_fp_get( lmin_cellidx c )
    {
    return cells[c].u.prim.fp;
    }
lmin_cellidx lmin_prim_vars_get( lmin_cellidx c )
    {
    return cells[c].u.prim.vars;
    }

/* CLOSURE */

lmin_cellidx lmin_closure_make( lmin_cellidx vars, lmin_cellidx body, lmin_cellidx defenv )
    {
    lmin_cellidx c = cell_make( CLOSURE ), r;
    r = check_typespecs( vars );
    if ( lmin_errex_is( r ) )
	return r;
    cells[c].u.closure.vars = vars;
    cells[c].u.closure.body = body;
    cells[c].u.closure.defenv = defenv == env ? nil : defenv;
    return c;
    }
bool lmin_closure_is( lmin_cellidx c )
    {
    return ct( c ) == CLOSURE;
    }
lmin_cellidx lmin_closure_vars_get( lmin_cellidx c )
    {
    return cells[c].u.closure.vars;
    }
lmin_cellidx lmin_closure_body_get( lmin_cellidx c )
    {
    return cells[c].u.closure.body;
    }
lmin_cellidx lmin_closure_defenv_get( lmin_cellidx c )
    {
    return cells[c].u.closure.defenv;
    }

/* MACRO */

lmin_cellidx lmin_macro_make( lmin_cellidx vars, lmin_cellidx body )
    {
    lmin_cellidx c = cell_make( MACRO );
    /* Make sure all the vars are atoms. */
    if ( ! all_pred( vars, lmin_atom_is ) )
	return lmin_errex_err_make( "not all ATOMs - \"%s\"", lmin_tocstring( vars ) );
    cells[c].u.macro.vars = vars;
    cells[c].u.macro.body = body;
    return c;
    }
bool lmin_macro_is( lmin_cellidx c )
    {
    return ct( c ) == MACRO;
    }
lmin_cellidx lmin_macro_vars_get( lmin_cellidx c )
    {
    return cells[c].u.macro.vars;
    }
lmin_cellidx lmin_macro_body_get( lmin_cellidx c )
    {
    return cells[c].u.macro.body;
    }

/* NUM */

lmin_cellidx lmin_num_make( long in, double fl, bool integer_is )
    {
    lmin_cellidx c = cell_make( NUM );
    cells[c].u.num.in = in;
    cells[c].u.num.fl = fl;
    if ( integer_is )
	cell_integer_set( c );
    return c;
    }
lmin_cellidx lmin_num_integer_make( long in )
    {
    return lmin_num_make( in, (double) in, true );
    }
lmin_cellidx lmin_num_float_make( double fl )
    {
    return lmin_num_make( (long) fl, fl, false );
    }
bool lmin_num_is( lmin_cellidx c )
    {
    return ct( c ) == NUM;
    }
bool lmin_num_integer_is( lmin_cellidx c )
    {
    return lmin_num_is( c ) && cell_integer_is( c ) && ! isnan( cells[c].u.num.fl );
    }
long lmin_num_integer_get( lmin_cellidx c )
    {
    if ( lmin_num_integer_is( c ) )
	return cells[c].u.num.in;
    else
	return (long) cells[c].u.num.fl;
    }
double lmin_num_float_get( lmin_cellidx c )
    {
    return cells[c].u.num.fl;
    }

/* CHR */

lmin_cellidx lmin_chr_make( char ch )
    {
    lmin_cellidx c = cell_make( CHR );
    cells[c].u.chr.ch = ch;
    return c;
    }
bool lmin_chr_is( lmin_cellidx c )
    {
    return ct( c ) == CHR;
    }
char lmin_chr_get( lmin_cellidx c )
    {
    return cells[c].u.chr.ch;
    }

/* STR */

lmin_cellidx lmin_str_make( const char* s )
    {
    lmin_cellidx c = cell_make( STR );
    cells[c].u.str.s = STRDUP( s );
    if ( cells[c].u.str.s == (char*) 0 )
	{
	fprintf( stderr, "liblmin: out of memory\n" );
	exit( EX_SOFTWARE );
	}
    cells[c].u.str.len = strlen( cells[c].u.str.s );
    return c;
    }
lmin_cellidx lmin_str_makel( const char* s, size_t len )
    {
    /* Alternate maker routine where the length is passed in and the source
    ** string need not be null terminated. Useful for extracting substrings.
    */
    lmin_cellidx c = cell_make( STR );
    char* d;
    cells[c].u.str.s = MALLOC( len + 1 );
    if ( cells[c].u.str.s == (char*) 0 )
	{
	fprintf( stderr, "liblmin: out of memory\n" );
	exit( EX_SOFTWARE );
	}
    d = cells[c].u.str.s;
    strncpy( d, s, len );
    d[len] = '\0';
    cells[c].u.str.len = len;
    return c;
    }
lmin_cellidx lmin_str_make2( const char* s1, const char* s2 )
    {
    /* Another alternate maker routine which takes two source strings
    ** and concatenates them.
    */
    lmin_cellidx c = cell_make( STR );
    char* d;
    size_t len1 = strlen( s1 );
    size_t len2 = strlen( s2 );
    cells[c].u.str.s = MALLOC( len1 + len2 + 1 );
    if ( cells[c].u.str.s == (char*) 0 )
	{
	fprintf( stderr, "liblmin: out of memory\n" );
	exit( EX_SOFTWARE );
	}
    d = cells[c].u.str.s;
    strcpy( d, s1 );
    strcpy( &d[len1], s2 );
    cells[c].u.str.len = len1 + len2;
    return c;
    }
bool lmin_str_is( lmin_cellidx c )
    {
    return ct( c ) == STR;
    }
const char* lmin_str_get( lmin_cellidx c )
    {
    return cells[c].u.str.s;
    }
size_t lmin_str_len_get( lmin_cellidx c )
    {
    return cells[c].u.str.len;
    }
lmin_cellidx lmin_str_chrat( lmin_cellidx c, size_t p )
    {
    if ( p >= lmin_str_len_get( c ) )
	return lmin_errex_err_make( "pos out of bounds - %ld", p );
    return lmin_chr_make( lmin_str_get( c )[p] );
    }

/* STREAM */

bool lmin_stream_is( lmin_cellidx c )
    {
    return ct( c ) == STREAM;
    }
FILE* lmin_stream_get( lmin_cellidx c )
    {
    return cells[c].u.stream.fp;
    }
lmin_cellidx lmin_stream_make( FILE* fp )
    {
    lmin_cellidx c = cell_make( STREAM );
    cells[c].u.stream.fp = fp;
    return c;
    }
lmin_cellidx lmin_stream_open( const char* path, const char* mode )
    {
    FILE* fp;
    fp = fopen( path, mode );
    if ( fp == (FILE*) 0 )
	return lmin_errex_err_make( "error opening %s - %s", path, strerror( errno ) );
    return lmin_stream_make( fp );
    }
void lmin_stream_close( lmin_cellidx c )
    {
    FILE* fp = lmin_stream_get( c );
    if ( fp != (FILE*) 0 )
	{
	fclose( fp );
	cells[c].u.stream.fp = (FILE*) 0;
	}
    }
void lmin_stream_flush( lmin_cellidx c )
    {
    FILE* fp = lmin_stream_get( c );
    if ( fp != (FILE*) 0 )
	fflush( fp );
    }

/* VECTOR */

lmin_cellidx lmin_vector_make( size_t len, lmin_cellidx fill )
    {
    lmin_cellidx c = cell_make( VECTOR );
    size_t i;
    cells[c].u.vec.v = (lmin_cellidx*) MALLOC( len * sizeof(lmin_cellidx) );
    if ( cells[c].u.vec.v == (lmin_cellidx*) 0 )
	{
	fprintf( stderr, "liblmin: out of memory\n" );
	exit( EX_SOFTWARE );
	}
    cells[c].u.vec.maxlen = cells[c].u.vec.curlen = len;
    for ( i = 0; i < len; ++i )
	cells[c].u.vec.v[i] = fill;
    lmin_vector_fill_set( c, fill );
    return c;
    }
bool lmin_vector_is( lmin_cellidx c )
    {
    return ct( c ) == VECTOR;
    }
lmin_cellidx* lmin_vector_getvec( lmin_cellidx c )
    {
    return cells[c].u.vec.v;
    }
size_t lmin_vector_len_get( lmin_cellidx c )
    {
    return cells[c].u.vec.curlen;
    }
void lmin_vector_len_set( lmin_cellidx c, size_t len )
    {
    if ( len > cells[c].u.vec.maxlen )
	{
	/* Enlarge the vector. Leave plenty of extra room. */
	size_t newmaxlen = max( len * 2, cells[c].u.vec.maxlen * 2 ), i;
	lmin_cellidx* newvec = (lmin_cellidx*) MALLOC( newmaxlen * sizeof(lmin_cellidx) );
	if ( newvec == (lmin_cellidx*) 0 )
	    {
	    fprintf( stderr, "liblmin: out of memory\n" );
	    exit( EX_SOFTWARE );
	    }
	for ( i = 0; i < newmaxlen; ++i )
	    if ( i < cells[c].u.vec.curlen )
		newvec[i] = cells[c].u.vec.v[i];
	    else
		newvec[i] = cells[c].u.vec.fill;
	FREE( (void*) cells[c].u.vec.v );
	cells[c].u.vec.v = newvec;
	cells[c].u.vec.maxlen = newmaxlen;
	}
    cells[c].u.vec.curlen = len;
    }
lmin_cellidx lmin_vector_get( lmin_cellidx c, size_t idx )
    {
    if ( idx >= lmin_vector_len_get( c ) )
	return cells[c].u.vec.fill;
    return cells[c].u.vec.v[idx];
    }
lmin_cellidx lmin_vector_set( lmin_cellidx c, size_t idx, lmin_cellidx val )
    {
    if ( idx >= cells[c].u.vec.maxlen )
	lmin_vector_len_set( c, idx + 1 );
    if ( idx >= cells[c].u.vec.curlen )
	cells[c].u.vec.curlen = idx + 1;
    cells[c].u.vec.v[idx] = val;
    return c;
    }
lmin_cellidx lmin_vector_fill_get( lmin_cellidx c )
    {
    return cells[c].u.vec.fill;
    }
void lmin_vector_fill_set( lmin_cellidx c, lmin_cellidx fill )
    {
    cells[c].u.vec.fill = fill;
    }

/* DATA */

lmin_cellidx lmin_data_make( void* ptr, lmin_freefp freefp )
    {
    lmin_cellidx c = cell_make( DATA );
    cells[c].u.data.ptr = ptr;
    cells[c].u.data.freefp = freefp;
    return c;
    }
bool lmin_data_is( lmin_cellidx c )
    {
    return ct( c ) == DATA;
    }
void* lmin_data_ptr_get( lmin_cellidx c )
    {
    return cells[c].u.data.ptr;
    }
lmin_freefp lmin_data_freefp_get( lmin_cellidx c )
    {
    return cells[c].u.data.freefp;
    }

/* ERREX */

bool lmin_errex_is( lmin_cellidx c )
    {
    return ct( c ) == ERREX;
    }
lmin_cellidx lmin_errex_payload_get( lmin_cellidx c )
    {
    return cells[c].u.errex.payload;
    }
lmin_cellidx lmin_errex_callstack_get( lmin_cellidx c )
    {
    return cells[c].u.errex.callstack;
    }

/* ERREX err */

lmin_cellidx lmin_errex_err_str_make( lmin_cellidx str )
    {
    lmin_cellidx c = cell_make( ERREX );
    cells[c].u.errex.payload = str;
    cells[c].u.errex.callstack = callstack;
    return c;
    }
lmin_cellidx lmin_errex_err_make( const char* format, ... )
    {
    char msg[1000];
    va_list args;
    va_start( args, format );
    vsnprintf( msg, sizeof(msg), format, args );
    va_end( args );
    return lmin_errex_err_str_make( lmin_str_make( msg ) );
    }
bool lmin_errex_err_is( lmin_cellidx c )
    {
    return lmin_errex_is( c ) && lmin_str_is( lmin_errex_payload_get( c ) );
    }
const char* lmin_errex_err_str_get( lmin_cellidx c )
    {
    return lmin_str_get( lmin_errex_payload_get( c ) );
    }

/* ERREX exception */

lmin_cellidx lmin_errex_exception_make( lmin_cellidx tag, lmin_cellidx value )
    {
    lmin_cellidx c = cell_make( ERREX );
    cells[c].u.errex.payload = cons( tag, value );
    cells[c].u.errex.callstack = callstack;
    return c;
    }
bool lmin_errex_exception_is( lmin_cellidx c )
    {
    return lmin_errex_is( c ) && lmin_cons_is( lmin_errex_payload_get( c ) );
    }
lmin_cellidx lmin_errex_exception_tag_get( lmin_cellidx c )
    {
    return car( lmin_errex_payload_get( c ) );
    }
lmin_cellidx lmin_errex_exception_value_get( lmin_cellidx c )
    {
    return cdr( lmin_errex_payload_get( c ) );
    }
