format.c   [plain text]

/*
 * Copyright (c) 2002 by The XFree86 Project, Inc.
 *
 * Permission is hereby granted, free of charge, to any person obtaining a
 * copy of this software and associated documentation files (the "Software"),
 * to deal in the Software without restriction, including without limitation
 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
 * and/or sell copies of the Software, and to permit persons to whom the
 * Software is furnished to do so, subject to the following conditions:
 *
 * The above copyright notice and this permission notice shall be included in
 * all copies or substantial portions of the Software.
 *  
 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
 * SOFTWARE.
 *
 * Except as contained in this notice, the name of the XFree86 Project shall
 * not be used in advertising or otherwise to promote the sale, use or other
 * dealings in this Software without prior written authorization from the
 * XFree86 Project.
 *
 * Author: Paulo César Pereira de Andrade
 */

/* $XFree86: xc/programs/xedit/lisp/format.c,v 1.29tsi Exp $ */

#include "lisp/io.h"
#include "lisp/write.h"
#include "lisp/format.h"
#include <ctype.h>

#define MAXFMT			8
#define NOERROR			0

/* parse error codes */
#define PARSE_2MANYPARM		1	/* too many directive parameters */
#define PARSE_2MANYATS		2	/* more than one @ in directive */
#define PARSE_2MANYCOLS		3	/* more than one : in directive */
#define PARSE_NOARGSLEFT	4	/* no arguments left to format */
#define PARSE_BADFMTARG		5	/* argument is not an integer or char */
#define PARSE_BADDIRECTIVE	6	/* unknown format directive */
#define PARSE_BADINTEGER	7	/* bad integer representation */

/* merge error codes */
#define MERGE_2MANY		1	/* too many parameters to directive */
#define MERGE_NOCHAR		2	/* parameter must be a character */
#define MERGE_NOINT		3	/* parameter must be an integer */

/* generic error codes */
#define GENERIC_RADIX		1	/* radix not in range 2-36 */
#define GENERIC_NEGATIVE	2	/* parameter is negative */
#define GENERIC_BADSTRING	3	/* argument is not a string */
#define GENERIC_BADLIST		4	/* argument is not a list */

#define IF_SPECIFIED(arg)	(arg).specified ? &((arg).value) : NULL

#define UPANDOUT_NORMAL		1
#define UPANDOUT_COLLON		2
#define UPANDOUT_HASH		4	/* only useful inside a ~{ iteration
					 * forces loop finalization. */

#define ITERATION_NORMAL	1
#define ITERATION_LAST		2

/*
 * Types
 */
/* parameter to format */
typedef struct {
    unsigned int achar : 1;	/* value was specified as a character */
    unsigned int specified : 1;	/* set if value was specified */
    unsigned int offset : 30;	/* offset in format string, for error printing */
    int value;
} FmtArg;

/* information about format parameters */
typedef struct {
    unsigned int atsign : 1;	/* @ specified */
    unsigned int collon : 1;	/* : specified */
    unsigned int command : 8;	/* the format command */
    unsigned int count : 4;	/* number of arguments processed */
    unsigned int offset : 10;	/* offset in format string, for error printing */
    char *base, *format;
    FmtArg arguments[MAXFMT];
} FmtArgs;

/* used for combining default format parameter values */
typedef struct {
    int achar;
    int value;
} FmtDef;

/* number of default format parameter values and defaults */
typedef struct {
    int count;
    FmtDef defaults[MAXFMT];
} FmtDefs;

/* used on recursive calls to LispFormat */
typedef struct {
    FmtArgs args;
    LispObj *base_arguments;	/* pointer to first format argument */
    int total_arguments;	/* number of objects in base_arguments */
    char **format;		/* if need to update format string pointer */
    LispObj **object;		/* CAR(arguments), for plural check */
    LispObj **arguments;	/* current element of base_arguments */
    int *num_arguments;		/* number of arguments after arguments */
    int upandout;		/* information for recursive calls */
    int iteration;		/* only set if in ~:{... or ~:@{ and in the
				 * last argument list, hint for upandout */
} FmtInfo;

/*
 * Prototypes
 */
static void merge_arguments(FmtArgs*, FmtDefs*, int*);
static char *parse_arguments(char*, FmtArgs*, int*, LispObj**, int*);
static void merge_error(FmtArgs*, int);
static void parse_error(FmtArgs*, int);
static void generic_error(FmtArgs*, int);
static void format_error(FmtArgs*, char*);

static int format_object(LispObj*, LispObj*);

static void format_ascii(LispObj*, LispObj*, FmtArgs*);
static void format_in_radix(LispObj*, LispObj*, int, FmtArgs*);
static void format_radix_special(LispObj*, LispObj*, FmtArgs*);
static void format_roman(LispObj*, LispObj*, FmtArgs*);
static void format_english(LispObj*, LispObj*, FmtArgs*);
static void format_character(LispObj*, LispObj*, FmtArgs*);
static void format_fixed_float(LispObj*, LispObj*, FmtArgs*);
static void format_exponential_float(LispObj*, LispObj*, FmtArgs*);
static void format_general_float(LispObj*, LispObj*, FmtArgs*);
static void format_dollar_float(LispObj*, LispObj*, FmtArgs*);
static void format_tabulate(LispObj*, FmtArgs*);

static void format_goto(FmtInfo*);
static void format_indirection(LispObj*, LispObj*, FmtInfo*);

static void list_formats(FmtInfo*, int, char**, char***, int*, int*, int*, int*);
static void free_formats(char**, int);

static void format_case_conversion(LispObj*, FmtInfo*);
static void format_conditional(LispObj*, FmtInfo*);
static void format_iterate(LispObj*, FmtInfo*);
static void format_justify(LispObj*, FmtInfo*);

static void LispFormat(LispObj*, FmtInfo*);

/*
 * Initialization
 */
static FmtDefs AsciiDefs = {
    4,
    {
	{0, 0},			/* mincol */
	{0, 1},			/* colinc */
	{0, 0},			/* minpad */
	{1, ' '},		/* padchar */
    },
};

static FmtDefs IntegerDefs = {
    4,
    {
	{0, 0},			/* mincol */
	{1, ' '},		/* padchar */
	{1, ','},		/* commachar */
	{0, 3},			/* commainterval */
    },
};

static FmtDefs RadixDefs = {
    5,
    {
	{0, 10},		/* radix */
	{0, 0},			/* mincol */
	{1, ' '},		/* padchar */
	{1, ','},		/* commachar */
	{0, 3},			/* commainterval */
    },
};

static FmtDefs NoneDefs = {
    0,
};

static FmtDefs FixedFloatDefs = {
    5,
    {
	{0, 0},			/* w */
	{0, 16},		/* d */
	{0, 0},			/* k */
	{1, '\0'},		/* overflowchar */
	{1, ' '},		/* padchar */
    },
};

static FmtDefs ExponentialFloatDefs = {
    7,
    {
	{0, 0},			/* w */
	{0, 16},		/* d */
	{0, 0},			/* e */
	{0, 1},			/* k */
	{1, '\0'},		/* overflowchar */
	{1, ' '},		/* padchar */
	{1, 'E'},		/* exponentchar */
	/* XXX if/when more than one float format,
	 * should default to object type */
    },
};

static FmtDefs DollarFloatDefs = {
    4,
    {
	{0, 2},			/* d */
	{0, 1},			/* n */
	{0, 0},			/* w */
	{1, ' '},		/* padchar */
    },
};

static FmtDefs OneDefs = {
    1,
    {
	{0, 1},
    },
};

static FmtDefs TabulateDefs = {
    2,
    {
	{0, 0},			/* colnum */
	{0, 1},			/* colinc */
    },
};

extern LispObj *Oprint_escape;

/*
 * Implementation
 */
static void
merge_arguments(FmtArgs *arguments, FmtDefs *defaults, int *code)
{
    int count;
    FmtDef *defaul;
    FmtArg *argument;

    defaul = &(defaults->defaults[0]);
    argument = &(arguments->arguments[0]);
    for (count = 0; count < defaults->count; count++, argument++, defaul++) {
	if (count >= arguments->count)
	    argument->specified = 0;
	if (argument->specified) {
	    if (argument->achar != defaul->achar) {
		*code = defaul->achar ? MERGE_NOCHAR : MERGE_NOINT;
		arguments->offset = argument->offset;
		return;
	    }
	}
	else {
	    argument->specified = 0;
	    argument->achar = defaul->achar;
	    argument->value = defaul->value;
	}
    }

    /* check if extra arguments were provided */
    if (arguments->count > defaults->count)
	*code = MERGE_2MANY;
}

/* the pointer arguments may be null, useful when just testing/parsing
 * the directive parameters */
static char *
parse_arguments(char *format, FmtArgs *arguments,
		int *num_objects, LispObj **objects, int *code)
{
    int test;
    char *ptr;
    FmtArg *argument;
    unsigned int tmpcmd = 0;

    /* initialize */
    test = objects == NULL || code == NULL || num_objects == NULL;
    ptr = format;
    argument = &(arguments->arguments[0]);
    arguments->atsign = arguments->collon = arguments->command = 0;

    /* parse format parameters */
    for (arguments->count = 0;; arguments->count++) {
	arguments->offset = ptr - format + 1;
	if (arguments->count >= MAXFMT) {
	    if (!test)
		*code = PARSE_2MANYPARM;
	    return (ptr);
	}
	if (*ptr == '\'') {		/* character parameter value */
	    ++ptr;			/* skip ' */
	    argument->achar = argument->specified = 1;
	    argument->value = *ptr++;
	}
	else if (*ptr == ',') {		/* use default parameter value */
	    argument->achar = 0;
	    argument->specified = 0;
	    /* don't increment ptr, will be incremented below */
	}
	else if (*ptr == '#') {		/* number of arguments is value */
	    ++ptr;			/* skip # */
	    argument->achar = 0;
	    argument->specified = 1;
	    if (!test)
		argument->value = *num_objects;
	}
	else if (*ptr == 'v' ||
		 *ptr == 'V') {		/* format object argument is value */
	    LispObj *object;

	    ++ptr;			/* skip V */
	    if (!test) {
		if (!CONSP(*objects)) {
		    *code = PARSE_NOARGSLEFT;
		    return (ptr);
		}
		object = CAR((*objects));
		if (FIXNUMP(object)) {
		    argument->achar = 0;
		    argument->specified = 1;
		    argument->value = FIXNUM_VALUE(object);
		}
		else if (SCHARP(object)) {
		    argument->achar = argument->specified = 1;
		    argument->value = SCHAR_VALUE(object);
		}
		else {
		    *code = PARSE_BADFMTARG;
		    return (ptr);
		}
		*objects = CDR(*objects);
		--*num_objects;
	    }
	}
	else if (isdigit(*ptr) ||
		*ptr == '-' || *ptr == '+') {	/* integer parameter value */
	    int sign;

	    argument->achar = 0;
	    argument->specified = 1;
	    if (!isdigit(*ptr)) {
		sign = *ptr++ == '-';
	    }
	    else
		sign = 0;
	    if (!test && !isdigit(*ptr)) {
		*code = PARSE_BADINTEGER;
		return (ptr);
	    }
	    argument->value = *ptr++ - '0';
	    while (isdigit(*ptr)) {
		argument->value = (argument->value * 10) + (*ptr++ - '0');
		if (argument->value > 65536) {
		    if (!test) {
			*code = PARSE_BADINTEGER;
			return (ptr);
		    }
		}
	    }
	    if (sign)
		argument->value = -argument->value;
	}
	else				/* no more arguments to format */
	    break;

	if (*ptr == ',')
	    ++ptr;

	/* remember offset of format parameter, for better error printing */
	argument->offset = arguments->offset;
	argument++;
    }

    /* check for extra flags */
    for (;;) {
	if (*ptr == '@') {		/* check for special parameter atsign */
	    if (arguments->atsign) {
		if (!test) {
		    *code = PARSE_2MANYATS;
		    return (ptr);
		}
	    }
	    ++ptr;
	    ++arguments->offset;
	    arguments->atsign = 1;
	}
	else if (*ptr == ':') {		/* check for special parameter collon */
	    if (arguments->collon) {
		if (!test) {
		    *code = PARSE_2MANYCOLS;
		    return (ptr);
		}
	    }
	    ++ptr;
	    ++arguments->offset;
	    arguments->collon = 1;
	}
	else				/* next value is format command */
	    break;
    }

    if (!test)
	*code = NOERROR;
    arguments->command = *ptr++;
    tmpcmd = arguments->command;
    if (islower(tmpcmd))
	arguments->command = toupper(tmpcmd);
    ++arguments->offset;

    return (ptr);
}

static void
parse_error(FmtArgs *args, int code)
{
    static char *errors[] = {
	NULL,
	"too many parameters to directive",
	"too many @ parameters",
	"too many : parameters",
	"no arguments left to format",
	"argument is not a fixnum integer or a character",
	"unknown format directive",
	"parameter is not a fixnum integer",
    };

    format_error(args, errors[code]);
}

static void
merge_error(FmtArgs *args, int code)
{
    static char *errors[] = {
	NULL,
	"too many parameters to directive",
	"argument must be a character",
	"argument must be a fixnum integer",
    };

    format_error(args, errors[code]);
}

static void
generic_error(FmtArgs *args, int code)
{
    static char *errors[] = {
	NULL,
	"radix must be in the range 2 to 36, inclusive",
	"parameter must be positive",
	"argument must be a string",
	"argument must be a list",
    };

    format_error(args, errors[code]);
}

static void
format_error(FmtArgs *args, char *str)
{
    char *message;
    int errorlen, formatlen;

    /* number of bytes of format to be printed */
    formatlen = (args->format - args->base) + args->offset;

    /* length of specific error message */
    errorlen = strlen(str) + 1;			/* plus '\n' */

    /* XXX allocate string with LispMalloc,
     * so that it will be freed in LispTopLevel */
    message = LispMalloc(formatlen + errorlen + 1);

    sprintf(message, "%s\n", str);
    memcpy(message + errorlen, args->base, formatlen);
    message[errorlen + formatlen] = '\0';

    LispDestroy("FORMAT: %s", message);
}

static int
format_object(LispObj *stream, LispObj *object)
{
    int length;

    length = LispWriteObject(stream, object);

    return (length);
}

static void
format_ascii(LispObj *stream, LispObj *object, FmtArgs *args)
{
    GC_ENTER();
    LispObj *string = NIL;
    int length = 0,
	atsign = args->atsign,
	collon = args->collon,
	mincol = args->arguments[0].value,
	colinc = args->arguments[1].value,
	minpad = args->arguments[2].value,
	padchar = args->arguments[3].value;

    /* check/correct arguments */
    if (mincol < 0)
	mincol = 0;
    if (colinc < 0)
	colinc = 1;
    if (minpad < 0)
	minpad = 0;
    /* XXX pachar can be the null character? */

    if (object == NIL)
	length = collon ? 2 : 3;	    /* () or NIL */

    /* left padding */
    if (atsign) {
	/* if length not yet known */
	if (object == NIL) {
	    string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
	    GC_PROTECT(string);
	    length = LispWriteObject(string, object);
	}

	/* output minpad characters at left */
	if (minpad) {
	    length += minpad;
	    LispWriteChars(stream, padchar, minpad);
	}

	if (colinc) {
	    /* puts colinc spaces at a time,
	     * until at least mincol chars out */
	    while (length < mincol) {
		LispWriteChars(stream, padchar, colinc);
		length += colinc;
	    }
	}
    }

    if (object == NIL) {
	if (collon)
	    LispWriteStr(stream, "()", 2);
	else
	    LispWriteStr(stream,  Snil->value, 3);
    }
    else {
	/* if string is not NIL, atsign was specified
	 * and object printed to string */
	if (string == NIL)
	    length = format_object(stream, object);
	else {
	    int size;
	    char *str = LispGetSstring(SSTREAMP(string), &size);

	    LispWriteStr(stream, str, size);
	}
    }

    /* right padding */
    if (!atsign) {
	/* output minpad characters at left */
	if (minpad) {
	    length += minpad;
	    LispWriteChars(stream, padchar, minpad);
	}
	if (colinc) {
	    /* puts colinc spaces at a time,
	     * until at least mincol chars out */
	    while (length < mincol) {
		LispWriteChars(stream, padchar, colinc);
		length += colinc;
	    }
	}
    }

    GC_LEAVE();
}

/* assumes radix is 0 or in range 2 - 36 */
static void
format_in_radix(LispObj *stream, LispObj *object, int radix, FmtArgs *args)
{
    if (INTEGERP(object)) {
	int i, atsign, collon, mincol, padchar, commachar, commainterval;

	i = (radix == 0);
	atsign = args->atsign;
	collon = args->collon;
	if (radix == 0) {
	    radix = args->arguments[0].value;
	    if (radix < 2 || radix > 36) {
		args->offset = args->arguments[0].offset;
		generic_error(args, GENERIC_RADIX);
	    }
	}
	mincol = args->arguments[i++].value;
	padchar = args->arguments[i++].value;
	commachar = args->arguments[i++].value;
	commainterval = args->arguments[i++].value;

	LispFormatInteger(stream, object, radix, atsign, collon,
			  mincol, padchar, commachar, commainterval);
    }
    else
	format_object(stream, object);
}

static void
format_radix_special(LispObj *stream, LispObj *object, FmtArgs *args)
{
    if (FIXNUMP(object)) {
	if (args->atsign)
	    format_roman(stream, object, args);
	else
	    format_english(stream, object, args);
    }
    else
	format_object(stream, object);
}

static void
format_roman(LispObj *stream, LispObj *object, FmtArgs *args)
{
    long value = 0;
    int cando, new_roman = args->collon == 0;

    if (FIXNUMP(object)) {
	value = FIXNUM_VALUE(object);
	if (new_roman)
	    cando = value >= 1 && value <= 3999;
	else
	    cando = value >= 1 && value <= 4999;
    }
    else
	cando = 0;

    if (cando)
	LispFormatRomanInteger(stream, value, new_roman);
    else
	format_object(stream, object);
}

static void
format_english(LispObj *stream, LispObj *object, FmtArgs *args)
{
    int cando;
    long number = 0;

    if (FIXNUMP(object)) {
	number = FIXNUM_VALUE(object);
	cando = number >= -999999999 && number <= 999999999;
    }
    else
	cando = 0;

    if (cando)
	LispFormatEnglishInteger(stream, number, args->collon);
    else
	format_object(stream, object);
}

static void
format_character(LispObj *stream, LispObj *object, FmtArgs *args)
{
    if (SCHARP(object))
	LispFormatCharacter(stream, object, args->atsign, args->collon);
    else
	format_object(stream, object);
}

static void
format_fixed_float(LispObj *stream, LispObj *object, FmtArgs *args)
{
    if (FLOATP(object))
	LispFormatFixedFloat(stream, object, args->atsign,
			     args->arguments[0].value,
			     IF_SPECIFIED(args->arguments[1]),
			     args->arguments[2].value,
			     args->arguments[3].value,
			     args->arguments[4].value);
    else
	format_object(stream, object);
}

static void
format_exponential_float(LispObj *stream, LispObj *object, FmtArgs *args)
{
    if (FLOATP(object))
	LispFormatExponentialFloat(stream, object, args->atsign,
				   args->arguments[0].value,
				   IF_SPECIFIED(args->arguments[1]),
				   args->arguments[2].value,
				   args->arguments[3].value,
				   args->arguments[4].value,
				   args->arguments[5].value,
				   args->arguments[6].value);
    else
	format_object(stream, object);
}

static void
format_general_float(LispObj *stream, LispObj *object, FmtArgs *args)
{
    if (FLOATP(object))
	LispFormatGeneralFloat(stream, object, args->atsign,
				args->arguments[0].value,
				IF_SPECIFIED(args->arguments[1]),
				args->arguments[2].value,
				args->arguments[3].value,
				args->arguments[4].value,
				args->arguments[5].value,
				args->arguments[6].value);
    else
	format_object(stream, object);
}

static void
format_dollar_float(LispObj *stream, LispObj *object, FmtArgs *args)
{
    if (FLOATP(object))
	LispFormatDollarFloat(stream, object,
			      args->atsign, args->collon,
			      args->arguments[0].value,
			      args->arguments[1].value,
			      args->arguments[2].value,
			      args->arguments[3].value);
    else
	format_object(stream, object);
}

static void
format_tabulate(LispObj *stream, FmtArgs *args)
{
    int atsign = args->atsign,
	colnum = args->arguments[0].value,
	colinc = args->arguments[1].value,
	column;

    column = LispGetColumn(stream);

    if (atsign) {
	/* relative tabulation */
	if (colnum > 0) {
	    LispWriteChars(stream, ' ', colnum);
	    column += colnum;
	}
	/* tabulate until at a multiple of colinc */
	if (colinc > 0)
	    LispWriteChars(stream, ' ', colinc - (column % colinc));
    }
    else {
	/* if colinc not specified, just move to given column */
	if (colinc <= 0)
	    LispWriteChars(stream, ' ', column - colnum);
	else {
	    /* always output at least colinc spaces */
	    do {
		LispWriteChars(stream, ' ', colinc);
		colnum -= colinc;
	    } while (colnum > column);
	}
    }
}

static void
format_goto(FmtInfo *info)
{
    int count, num_arguments;
    LispObj *object, *arguments;

    /* number of arguments to ignore or goto offset */
    count = info->args.arguments[0].value;
    if (count < 0)
	generic_error(&(info->args), GENERIC_NEGATIVE);

    if (info->args.atsign) {
	/* absolute goto */

	/* if not specified, defaults to zero */
	if (!(info->args.arguments[0].specified))
	    count = 0;

	/* if offset too large */
	if (count > info->total_arguments)
	    parse_error(&(info->args), PARSE_NOARGSLEFT);
	else if (count != info->total_arguments - *(info->num_arguments)) {
	    /* calculate new parameters */
	    object = NIL;
	    arguments = info->base_arguments;
	    num_arguments = info->total_arguments - count;

	    for (; count > 0; count--, arguments = CDR(arguments))
		object = CAR(arguments);

	    /* update format information */
	    *(info->object) = object;
	    *(info->arguments) = arguments;
	    *(info->num_arguments) = num_arguments;
	}
    }
    else if (count) {
	/* relative goto, ignore or go back count arguments */

	/* prepare to update parameters */
	arguments = *(info->arguments);
	num_arguments = *(info->num_arguments);

	/* go back count arguments? */
	if (info->args.collon)
	    count = -count;

	num_arguments -= count;

	if (count > 0) {
	    if (count > *(info->num_arguments))
		parse_error(&(info->args), PARSE_NOARGSLEFT);

	    object = *(info->object);
	    for (; count > 0; count--, arguments = CDR(arguments))
		object = CAR(arguments);
	}
	else {		/* count < 0 */
	    if (info->total_arguments + count - *(info->num_arguments) < 0)
		parse_error(&(info->args), PARSE_NOARGSLEFT);

	    object = NIL;
	    arguments = info->base_arguments;
	    for (count = 0; count < info->total_arguments - num_arguments;
		count++, arguments = CDR(arguments))
		object = CAR(arguments);
	}

	/* update format parameters */
	*(info->object) = object;
	*(info->arguments) = arguments;
	*(info->num_arguments) = num_arguments;
    }
}

static void
format_indirection(LispObj *stream, LispObj *format, FmtInfo *info)
{
    char *string;
    LispObj *object;
    FmtInfo indirect_info;

    if (!STRINGP(format))
	generic_error(&(info->args), GENERIC_BADSTRING);
    string = THESTR(format);

    /* most information is the same */
    memcpy(&indirect_info, info, sizeof(FmtInfo));

    /* set new format string */
    indirect_info.args.base = indirect_info.args.format = string;
    indirect_info.format = &string;

    if (info->args.atsign) {
	/* use current arguments */

	/* do the indirect format */
	LispFormat(stream, &indirect_info);
    }
    else {
	/* next argument is the recursive call arguments */

	int num_arguments;

	/* it is valid to not have a list following string, as string may
	 * not have format directives */
	if (CONSP(*(indirect_info.arguments)))
	    object = CAR(*(indirect_info.arguments));
	else
	    object = NIL;

	if (!LISTP(object) || !CONSP(*(info->arguments)))
	    generic_error(&(info->args), GENERIC_BADLIST);

	/* update information now */
	*(info->object) = object;
	*(info->arguments) = CDR(*(info->arguments));
	*(info->num_arguments) -= 1;

	/* set arguments for recursive call */
	indirect_info.base_arguments = object;
	indirect_info.arguments = &object;
	for (num_arguments = 0; CONSP(object); object = CDR(object))
	    ++num_arguments;

	/* note that indirect_info.arguments is a pointer to "object",
	 * keep it pointing to the correct object */
	object = indirect_info.base_arguments;
	indirect_info.total_arguments = num_arguments;
	indirect_info.num_arguments = &num_arguments;

	/* do the indirect format */
	LispFormat(stream, &indirect_info);
    }
}

/* update pointers to a list of format strings:
 *	for '(' and '{' only one list is required
 *	for '[' and '<' more than one may be returned
 *	has_default is only meaningful for '[' and '<'
 *	comma_width and line_width are only meaningful to '<', and
 *	    only valid if has_default set
 * if the string is finished prematurely, LispDestroy is called
 * format_ptr is updated to the correct pointer in the "main" format string
 */
static void
list_formats(FmtInfo *info, int command, char **format_ptr,
	     char ***format_list, int *format_count, int *has_default,
	     int *comma_width, int *line_width)
{
    /* instead of processing the directives recursively, just separate the
     * input formats in separate strings, then see if one of then need to
     * be used */
    FmtArgs args;
    int counters[] = {  0,   0,   0,   0};
		    /* '[', '(', '{', '<' */
    char *format, *next_format, *start, **formats;
    int num_formats, format_index, separator, add_format;

    /* initialize */
    formats = NULL;
    num_formats = format_index = 0;
    if (has_default != NULL)
	*has_default = 0;
    if (comma_width != NULL)
	*comma_width = 0;
    if (line_width != NULL)
	*line_width = 0;
    format = start = next_format = *format_ptr;
    switch (command) {
	case '[': counters[0] = 1; format_index = 0; break;
	case '(': counters[1] = 1; format_index = 1; break;
	case '{': counters[2] = 1; format_index = 2; break;
	case '<': counters[3] = 1; format_index = 3; break;
    }

#define	LIST_FORMATS_ADD	1
#define	LIST_FORMATS_DONE	2

    /* fill list of format options to conditional */
    while (*format) {
	if (*format == '~') {
	    separator = add_format = 0;
	    args.format = format + 1;
	    next_format = parse_arguments(format + 1, &args, NULL, NULL, NULL);
	    switch (args.command) {
 		case '[': ++counters[0];    break;
		case ']': --counters[0];    break;
		case '(': ++counters[1];    break;
		case ')': --counters[1];    break;
		case '{': ++counters[2];    break;
		case '}': --counters[2];    break;
		case '<': ++counters[3];    break;
		case '>': --counters[3];    break;
		case ';': separator = 1;    break;
	    }

	    /* check if a new format string must be added */
	    if (separator && counters[format_index] == 1 &&
		(command == '[' || command == '<'))
		add_format = LIST_FORMATS_ADD;
	    else if (counters[format_index] == 0)
		add_format = LIST_FORMATS_DONE;

	    if (add_format) {
		int length = format - start;

		formats = LispRealloc(formats,
				      (num_formats + 1) * sizeof(char*));

		formats[num_formats] = LispMalloc(length + 1);
		strncpy(formats[num_formats], start, length);
		formats[num_formats][length] = '\0';
		++num_formats;
		/* loop finished? */
		if (add_format == LIST_FORMATS_DONE)
		    break;
		else if (command == '[' && has_default != NULL)
		    /* will be set only for the last parameter, what is
		     * expected, just don't warn about it in the incorrect
		     * place */
		    *has_default = args.collon != 0;
		else if (command == '<' && num_formats == 1) {
		    /* if the first parameter to '<', there may be overrides
		     * to comma-width and line-width */
		    if (args.collon && has_default != NULL) {
			*has_default = 1;
			if (comma_width != NULL &&
			    args.arguments[0].specified &&
			    !args.arguments[0].achar)
			    *comma_width = args.arguments[0].value;
			if (line_width != NULL &&
			    args.arguments[1].specified &&
			    !args.arguments[1].achar)
			    *line_width = args.arguments[1].value;
		    }
		}
		start = next_format;
	    }
	    format = next_format;
	}
	else
	    ++format;
    }

    /* check if format string did not finish prematurely */
    if (counters[format_index] != 0) {
	char error_message[64];

	sprintf(error_message, "expecting ~%c", command);
	format_error(&(info->args), error_message);
    }

    /* update pointers */
    *format_list = formats;
    *format_count = num_formats;
    *format_ptr = next_format;
}

static void
free_formats(char **formats, int num_formats)
{
    if (num_formats) {
	while (--num_formats >= 0)
	    LispFree(formats[num_formats]);
	LispFree(formats);
    }
}

static void
format_case_conversion(LispObj *stream, FmtInfo *info)
{
    GC_ENTER();
    LispObj *string;
    FmtInfo case_info;
    char *str, *ptr;
    char *format, *next_format, **formats;
    int atsign, collon, num_formats, length;

    atsign = info->args.atsign;
    collon = info->args.collon;

    /* output to a string, before case conversion */
    string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
    GC_PROTECT(string);

    /* most information is the same */
    memcpy(&case_info, info, sizeof(FmtInfo));

    /* list formats */
    next_format = *(info->format);
    list_formats(info, '(', &next_format, &formats, &num_formats,
		 NULL, NULL, NULL);

    /* set new format string */
    format = formats[0];
    case_info.args.base = case_info.args.format = format;
    case_info.format = &format;

    /* format text to string */
    LispFormat(string, &case_info);

    str = ptr = LispGetSstring(SSTREAMP(string), &length);

    /* do case conversion */
    if (!atsign && !collon) {
	/* convert all upercase to lowercase */
	for (; *ptr; ptr++) {
	    if (isupper(*ptr))
		*ptr = tolower(*ptr);
	}
    }
    else if (atsign && collon) {
	/* convert all lowercase to upercase */
	for (; *ptr; ptr++) {
	    if (islower(*ptr))
		*ptr = toupper(*ptr);
	}
    }
    else {
	int upper = 1;

	/* skip non-alphanumeric characters */
	for (; *ptr; ptr++)
	    if (isalnum(*ptr))
		break;

	/* capitalize words */
	for (; *ptr; ptr++) {
	    if (isalnum(*ptr)) {
		if (upper) {
		    if (islower(*ptr))
			*ptr = toupper(*ptr);
		    upper = 0;
		}
		else if (isupper(*ptr))
		    *ptr = tolower(*ptr);
	    }
	    else
		upper = collon;
		/* if collon, capitalize all words, else just first word */
	}
    }

    /* output case converted string */
    LispWriteStr(stream, str, length);

    /* temporary string stream is not necessary anymore */
    GC_LEAVE();

    /* free temporary memory */
    free_formats(formats, num_formats);

    /* this information always updated */
    *(info->format) = next_format;
}

static void
format_conditional(LispObj *stream, FmtInfo *info)
{
    LispObj *object, *arguments;
    char *format, *next_format, **formats;
    int choice, num_formats, has_default, num_arguments;

    /* save information that may change */
    object = *(info->object);
    arguments = *(info->arguments);
    num_arguments = *(info->num_arguments);

    /* initialize */
    choice = -1;
    next_format = *(info->format);

    /* list formats */
    list_formats(info, '[',
		 &next_format, &formats, &num_formats, &has_default, NULL, NULL);

    /* ~:[false;true] */
    if (info->args.collon) {
	/* one argument always consumed */
	if (!CONSP(arguments))
	    parse_error(&(info->args), PARSE_NOARGSLEFT);
	object = CAR(arguments);
	arguments = CDR(arguments);
	--num_arguments;
	choice = object == NIL ? 0 : 1;
    }
    /* ~@[true] */
    else if (info->args.atsign) {
	/* argument consumed only if nil, but one must be available */
	if (!CONSP(arguments))
	    parse_error(&(info->args), PARSE_NOARGSLEFT);
	if (CAR(arguments) != NIL)
	    choice = 0;
	else {
	    object = CAR(arguments);
	    arguments = CDR(arguments);
	    --num_arguments;
	}
    }
    /* ~n[...~] */
    else if (info->args.arguments[0].specified)
	/* no arguments consumed */
	choice = info->args.arguments[0].value;
    /* ~[...~] */
    else {
	/* one argument consumed, it is the index in the available formats */
	if (!CONSP(arguments))
	    parse_error(&(info->args), PARSE_NOARGSLEFT);
	object = CAR(arguments);
	arguments = CDR(arguments);
	--num_arguments;
	/* no error if it isn't a number? */
	if (FIXNUMP(object))
	    choice = FIXNUM_VALUE(object);
    }

    /* update anything that may have changed */
    *(info->object) = object;
    *(info->arguments) = arguments;
    *(info->num_arguments) = num_arguments;

    /* if choice is out of range check if there is a default choice */
    if (has_default && (choice < 0 || choice >= num_formats))
	choice = num_formats - 1;

    /* if one of the formats must be parsed */
    if (choice >= 0 && choice < num_formats) {
	FmtInfo conditional_info;

	/* most information is the same */
	memcpy(&conditional_info, info, sizeof(FmtInfo));

	/* set new format string */
	format = formats[choice];
	conditional_info.args.base = conditional_info.args.format = format;
	conditional_info.format = &format;

	/* do the conditional format */
	LispFormat(stream, &conditional_info);
    }

    /* free temporary memory */
    free_formats(formats, num_formats);

    /* this information always updated */
    *(info->format) = next_format;
}

static void
format_iterate(LispObj *stream, FmtInfo *info)
{
    FmtInfo iterate_info;
    LispObj *object, *arguments, *iarguments, *iobject;
    char *format, *next_format, *loop_format, **formats;
    int num_arguments, iterate, iterate_max, has_max, has_min, inum_arguments,
	num_formats;

    /* save information that may change */
    object = *(info->object);
    arguments = *(info->arguments);
    num_arguments = *(info->num_arguments);

    /* initialize */
    iterate = has_min = 0;
    next_format = *(info->format);

    /* if has_max set, iterate at most iterate_max times */
    has_max = info->args.arguments[0].specified;
    iterate_max = info->args.arguments[0].value;

    /* list formats */
    list_formats(info, '{', &next_format, &formats, &num_formats,
		 NULL, NULL, NULL);
    loop_format = formats[0];

    /* most information is the same */
    memcpy(&iterate_info, info, sizeof(FmtInfo));

    /* ~{...~} */
    if (!info->args.atsign && !info->args.collon) {
	/* next argument is the argument list for the iteration */

	/* fetch argument list, must exist */
	if (!CONSP(arguments))
	    parse_error(&(info->args), PARSE_NOARGSLEFT);
	iarguments = object = CAR(arguments);
	object = CAR(arguments);
	arguments = CDR(arguments);
	--num_arguments;

	inum_arguments = 0;
	if (CONSP(object)) {
	    /* count arguments to format */
	    for (iobject = object; CONSP(iobject); iobject = CDR(iobject))
		++inum_arguments;
	}
	else if (object != NIL)
	    generic_error(&(info->args), GENERIC_BADLIST);

	iobject = NIL;

	/* set new arguments to recursive calls */
	iarguments = object;
	iterate_info.base_arguments = iarguments;
	iterate_info.total_arguments = inum_arguments;
	iterate_info.object = &iobject;
	iterate_info.arguments = &iarguments;
	iterate_info.num_arguments = &inum_arguments;

	/* iterate */
	for (;; iterate++) {
	    /* if maximum iterations done or all arguments consumed */
	    if (has_max && iterate > iterate_max)
		break;
	    else if (inum_arguments == 0 && (!has_min || iterate > 0))
		break;

	    format = loop_format;

	    /* set new format string */
	    iterate_info.args.base = iterate_info.args.format = format;
	    iterate_info.format = &format;

	    /* information for possible ~^, in this case ~:^ is a noop */
	    iterate_info.iteration = ITERATION_NORMAL;

	    /* do the format */
	    LispFormat(stream, &iterate_info);

	    /* check for forced loop break */
	    if (iterate_info.upandout & UPANDOUT_HASH)
		break;
	}
    }
    /* ~:@{...~} */
    else if (info->args.atsign && info->args.collon) {
	/* every following argument is the argument list for the iteration */

	/* iterate */
	for (;; iterate++) {
	    /* if maximum iterations done or all arguments consumed */
	    if (has_max && iterate > iterate_max)
		break;
	    else if (num_arguments == 0 && (!has_min || iterate > 0))
		break;

	    /* fetch argument list, must exist */
	    if (!CONSP(arguments))
		parse_error(&(info->args), PARSE_NOARGSLEFT);
	    iarguments = object = CAR(arguments);
	    object = CAR(arguments);
	    arguments = CDR(arguments);
	    --num_arguments;

	    inum_arguments = 0;
	    if (CONSP(object)) {
		/* count arguments to format */
		for (iobject = object; CONSP(iobject); iobject = CDR(iobject))
		    ++inum_arguments;
	    }
	    else if (object != NIL)
		generic_error(&(info->args), GENERIC_BADLIST);

	    iobject = NIL;

	    /* set new arguments to recursive calls */
	    iarguments = object;
	    iterate_info.base_arguments = iarguments;
	    iterate_info.total_arguments = inum_arguments;
	    iterate_info.object = &iobject;
	    iterate_info.arguments = &iarguments;
	    iterate_info.num_arguments = &inum_arguments;

	    format = loop_format;

	    /* set new format string */
	    iterate_info.args.base = iterate_info.args.format = format;
	    iterate_info.format = &format;

	    /* information for possible ~^ */
	    iterate_info.iteration =
		num_arguments > 0 ? ITERATION_NORMAL : ITERATION_LAST;

	    /* do the format */
	    LispFormat(stream, &iterate_info);

	    /* check for forced loop break */
	    if (iterate_info.upandout & UPANDOUT_HASH)
		break;
	}
    }
    /* ~:{...~} */
    else if (info->args.collon) {
	/* next argument is a list of lists */

	LispObj *sarguments, *sobject;
	int snum_arguments;

	/* fetch argument list, must exist */
	if (!CONSP(arguments))
	    parse_error(&(info->args), PARSE_NOARGSLEFT);
	sarguments = object = CAR(arguments);
	object = CAR(arguments);
	arguments = CDR(arguments);
	--num_arguments;

	snum_arguments = 0;
	if (CONSP(object)) {
	    /* count arguments to format */
	    for (sobject = object; CONSP(sobject); sobject = CDR(sobject))
		++snum_arguments;
	}
	else
	    generic_error(&(info->args), GENERIC_BADLIST);

	/* iterate */
	for (;; iterate++) {
	    /* if maximum iterations done or all arguments consumed */
	    if (has_max && iterate > iterate_max)
		break;
	    else if (snum_arguments == 0 && (!has_min || iterate > 0))
		break;

	    /* fetch argument list, must exist */
	    if (!CONSP(sarguments))
		parse_error(&(info->args), PARSE_NOARGSLEFT);
	    iarguments = sobject = CAR(sarguments);
	    sobject = CAR(sarguments);
	    sarguments = CDR(sarguments);
	    --snum_arguments;

	    inum_arguments = 0;
	    if (CONSP(object)) {
		/* count arguments to format */
		for (iobject = sobject; CONSP(iobject); iobject = CDR(iobject))
		    ++inum_arguments;
	    }
	    else if (sobject != NIL)
		generic_error(&(info->args), GENERIC_BADLIST);

	    iobject = NIL;

	    /* set new arguments to recursive calls */
	    iarguments = sobject;
	    iterate_info.base_arguments = iarguments;
	    iterate_info.total_arguments = inum_arguments;
	    iterate_info.object = &iobject;
	    iterate_info.arguments = &iarguments;
	    iterate_info.num_arguments = &inum_arguments;

	    format = loop_format;

	    /* set new format string */
	    iterate_info.args.base = iterate_info.args.format = format;
	    iterate_info.format = &format;

	    /* information for possible ~^ */
	    iterate_info.iteration =
		snum_arguments > 0 ? ITERATION_NORMAL : ITERATION_LAST;

	    /* do the format */
	    LispFormat(stream, &iterate_info);

	    /* check for forced loop break */
	    if (iterate_info.upandout & UPANDOUT_HASH)
		break;
	}
    }
    /* ~@{...~} */
    else if (info->args.atsign) {
	/* current argument list is used */

	/* set new arguments to recursive calls */
	iterate_info.base_arguments = info->base_arguments;
	iterate_info.total_arguments = info->total_arguments;
	iterate_info.object = &object;
	iterate_info.arguments = &arguments;
	iterate_info.num_arguments = &num_arguments;

	for (;; iterate++) {
	    /* if maximum iterations done or all arguments consumed */
	    if (has_max && iterate > iterate_max)
		break;
	    else if (num_arguments == 0 && (!has_min || iterate > 0))
		break;

	    format = loop_format;

	    /* set new format string */
	    iterate_info.args.base = iterate_info.args.format = format;
	    iterate_info.format = &format;

	    /* information for possible ~^, in this case ~:^ is a noop */
	    iterate_info.iteration = ITERATION_NORMAL;

	    /* do the format */
	    LispFormat(stream, &iterate_info);

	    /* check for forced loop break */
	    if (iterate_info.upandout & UPANDOUT_HASH)
		break;
	}
    }

    /* free temporary memory */
    free_formats(formats, num_formats);

    /* update anything that may have changed */
    *(info->object) = object;
    *(info->arguments) = arguments;
    *(info->num_arguments) = num_arguments;

    /* this information always updated */
    *(info->format) = next_format;
}

static void
format_justify(LispObj *stream, FmtInfo *info)
{
    GC_ENTER();
    FmtInfo justify_info;
    char **formats, *format, *next_format, *str;
    LispObj *string, *strings = NIL, *cons;
    int atsign = info->args.atsign,
	collon = info->args.collon,
	mincol = info->args.arguments[0].value,
	colinc = info->args.arguments[1].value,
	minpad = info->args.arguments[2].value,
	padchar = info->args.arguments[3].value;
    int i, k, total_length, length, padding, num_formats, has_default,
	comma_width, line_width, size, extra;

    next_format = *(info->format);

    /* list formats */
    list_formats(info, '<', &next_format, &formats, &num_formats,
		 &has_default, &comma_width, &line_width);

    /* initialize list of strings streams */
    if (num_formats) {
	string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
	strings = cons = CONS(string, NIL);
	GC_PROTECT(strings);
	for (i = 1; i < num_formats; i++) {
	    string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
	    RPLACD(cons, CONS(string, NIL));
	    cons = CDR(cons);
	}
    }

    /* most information is the same */
    memcpy(&justify_info, info, sizeof(FmtInfo));

    /* loop formating strings */
    for (i = 0, cons = strings; i < num_formats; i++, cons = CDR(cons)) {
	/* set new format string */
	format = formats[i];
	justify_info.args.base = justify_info.args.format = format;
	justify_info.format = &format;

	/* format string, maybe consuming arguments */
	LispFormat(CAR(cons), &justify_info);

	/* if format was aborted, it is discarded */
	if (justify_info.upandout)
	    RPLACA(cons, NIL);
	/* check if the entire "main" iteration must be aborted */
	if (justify_info.upandout & UPANDOUT_COLLON) {
	    for (cons = CDR(cons); i < num_formats; i++, cons = CDR(cons))
		RPLACA(cons, NIL);
	    break;
	}
    }

    /* free temporary format strings */
    free_formats(formats, num_formats);

    /* remove aborted formats */
	/* first remove leading discarded formats */
    if (CAR(strings) == NIL) {
	while (CAR(strings) == NIL) {
	    strings = CDR(strings);
	    --num_formats;
	}
	/* keep strings gc protected, discarding first entries */
	lisp__data.protect.objects[gc__protect] = strings;
    }
	/* now remove intermediary discarded formats */
    cons = strings;
    while (CONSP(cons)) {
	if (CONSP(CDR(cons)) && CAR(CDR(cons)) == NIL) {
	    RPLACD(cons, CDR(CDR(cons)));
	    --num_formats;
	}
	else
	    cons = CDR(cons);
    }

    /* calculate total length required for output */
    if (has_default)
	cons = CDR(strings);	/* if has_defaults, strings is surely a list */
    else
	cons = strings;
    for (total_length = 0; CONSP(cons); cons = CDR(cons))
	total_length += SSTREAMP(CAR(cons))->length;

    /* initialize pointer to string streams */
    if (has_default)
	cons = CDR(strings);
    else
	cons = strings;

    /* check if padding will need to be printed */
    extra = 0;
    padding = mincol - total_length;
    if (padding < 0)
	k = padding = 0;
    else {
	int num_fields = num_formats - (has_default != 0);

	if (num_fields > 1) {
	    /* check if padding is distributed in num_fields or
	     * num_fields - 1 steps */
	    if (!collon)
		--num_fields;
	}

	if (num_fields)
	    k = padding / num_fields;
	else
	    k = padding;

	if (k <= 0)
	    k = colinc;
	else if (colinc)
	    k = k + (k % colinc);
	extra = mincol - (num_fields * k + total_length);
	if (extra < 0)
	    extra = 0;
    }
    if (padding && k < minpad) {
	k = minpad;
	if (colinc)
	    k = k + (k % colinc);
    }

    /* first check for the special case of only one string being justified */
    if (num_formats - has_default == 1) {
	if (has_default && line_width > 0 && comma_width >= 0 &&
	    total_length + comma_width > line_width) {
	    str = LispGetSstring(SSTREAMP(CAR(strings)), &size);
	    LispWriteStr(stream, str, size);
	}
	string = has_default ? CAR(CDR(strings)) : CAR(strings);
	/* check if need left padding */
	if (k && !atsign) {
	    LispWriteChars(stream, padchar, k);
	    k = 0;
	}
	/* check for centralizing text */
	else if (k && atsign && collon) {
	    LispWriteChars(stream, padchar, k / 2 + ((k / 2) & 1));
	    k -= k / 2;
	}
	str = LispGetSstring(SSTREAMP(string), &size);
	LispWriteStr(stream, str, size);
	/* if any padding remaining */
	if (k)
	    LispWriteChars(stream, padchar, k);
    }
    else {
	LispObj *result;
	int last, spaces_before, padout;

	/* if has default, need to check output length */
	if (has_default && line_width > 0 && comma_width >= 0) {
	    result = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
	    GC_PROTECT(result);
	}
	/* else write directly to stream */
	else
	    result = stream;

	/* loop printing justified text */
	    /* padout controls padding for cases where padding is
	     * is separated in n-1 chunks, where n is the number of
	     * formatted strings.
	     */
	for (i = padout = 0; CONSP(cons); i++, cons = CDR(cons), --extra) {
	    string = CAR(cons);
	    last = !CONSP(CDR(cons));

	    spaces_before = (i != 0 || collon) && (!last || !atsign);

	    if (!spaces_before) {
		/* check for special case */
		if (last && atsign && collon && padding > 0) {
		    int spaces;

		    spaces = minpad > colinc ? minpad : colinc;
		    LispWriteChars(result, padchar, spaces + (extra > 0));
		    k -= spaces;
		}
		str = LispGetSstring(SSTREAMP(string), &size);
		LispWriteStr(result, str, size);
		padout = 0;
	    }
	    if (!padout)
		LispWriteChars(result, padchar, k + (extra > 0));
	    padout = k;
	    /* if not first string, or if left padding specified */
	    if (spaces_before) {
		str = LispGetSstring(SSTREAMP(string), &size);
		LispWriteStr(result, str, size);
		padout = 0;
	    }
	    padding -= k;
	}

	if (has_default && line_width > 0 && comma_width >= 0) {
	    length = SSTREAMP(result)->length + LispGetColumn(stream);

	    /* if current line is too large */
	    if (has_default && length + comma_width > line_width) {
		str = LispGetSstring(SSTREAMP(CAR(strings)), &size);
		LispWriteStr(stream, str, size);
	    }

	    /* write result to stream */
	    str = LispGetSstring(SSTREAMP(result), &size);
	    LispWriteStr(stream, str, size);
	}
    }

    /* unprotect string streams from GC */
    GC_LEAVE();

    /* this information always updated */
    *(info->format) = next_format;
}

static void
LispFormat(LispObj *stream, FmtInfo *info)
{
    FmtArgs *args;
    FmtDefs *defs = NULL;
    LispObj *object, *arguments;
    char stk[256], *format, *next_format;
    int length, num_arguments, code, need_update, need_argument, hash, head;

    /* arguments that will be updated on function exit */
    format = *(info->format);
    object = *(info->object);
    arguments = *(info->arguments);
    num_arguments = *(info->num_arguments);

    /* initialize */
    length = 0;
    args = &(info->args);
    info->upandout = 0;

    while (*format) {
	if (*format == '~') {
	    /* flush non formatted characters */
	    if (length) {
		LispWriteStr(stream, stk, length);
		length = 0;
	    }

	    need_argument = need_update = hash = 0;

	    /* parse parameters */
	    args->format = format + 1;
	    next_format = parse_arguments(format + 1, args, &num_arguments,
					  &arguments, &code);
	    if (code != NOERROR)
		parse_error(args, code);

	    /* check parameters */
	    switch (args->command) {
		case 'A': case 'S':
		    defs = &AsciiDefs;
		    break;
		case 'B': case 'O': case 'D': case 'X':
		    defs = &IntegerDefs;
		    break;
		case 'R':
		    defs = &RadixDefs;
		    break;
		case 'P': case 'C':
		    defs = &NoneDefs;
		    break;
		case 'F':
		    defs = &FixedFloatDefs;
		    break;
		case 'E': case 'G':
		    defs = &ExponentialFloatDefs;
		    break;
		case '$':
		    defs = &DollarFloatDefs;
		    break;
		case '%': case '&': case '|': case '~': case '\n':
		    defs = &OneDefs;
		    break;
		case 'T':
		    defs = &TabulateDefs;
		    break;
		case '*':
		    defs = &OneDefs;
		    break;
		case '?': case '(':
		    defs = &NoneDefs;
		    break;
		case ')':
		    /* this is never seen, processed in format_case_conversion */
		    format_error(args, "no match for directive ~)");
		case '[':
		    defs = &OneDefs;
		    break;
		case ']':
		    /* this is never seen, processed in format_conditional */
		    format_error(args, "no match for directive ~]");
		case '{':
		    defs = &OneDefs;
		    break;
		case '}':
		    /* this is never seen, processed in format_iterate */
		    format_error(args, "no match for directive ~}");
		case '<':
		    defs = &AsciiDefs;
		    break;
		case '>':
		    /* this is never seen, processed in format_justify */
		    format_error(args, "no match for directive ~>");
		case ';':
		    /* this is never seen here */
		    format_error(args, "misplaced directive ~;");
		case '#':
		    /* special handling for ~#^ */
		    if (*next_format == '^') {
			++next_format;
			hash = 1;
			defs = &NoneDefs;
			args->command = '^';
			break;
		    }
		    parse_error(args, PARSE_BADDIRECTIVE);
		case '^':
		    defs = &NoneDefs;
		    break;
		default:
		    parse_error(args, PARSE_BADDIRECTIVE);
		    break;
	    }
	    merge_arguments(args, defs, &code);
	    if (code != NOERROR)
		merge_error(args, code);

	    /* check if an argument is required by directive */
	    switch (args->command) {
		case 'A': case 'S':
		case 'B': case 'O': case 'D': case 'X': case 'R':
		    need_argument = 1;
		    break;
		case 'P':
		    /* if collon specified, plural is the last print argument */
		    need_argument = !args->collon;
		    break;
		case 'C':
		    need_argument = 1;
		    break;
		case 'F': case 'E': case 'G': case '$':
		    need_argument = 1;
		    break;
		case '%': case '&': case '|': case '~': case '\n':
		    break;
		case 'T':
		    break;
		case '*':			/* check arguments below */
		    need_update = 1;
		    break;
		case '?':
		    need_argument = need_update = 1;
		    break;
		case '(': case '[': case '{': case '<':
		    need_update = 1;
		    break;
		case '^':
		    break;
	    }
	    if (need_argument) {
		if (!CONSP(arguments))
		    parse_error(args, PARSE_NOARGSLEFT);
		object = CAR(arguments);
		arguments = CDR(arguments);
		--num_arguments;
	    }

	    /* will do recursive calls that change info */
	    if (need_update) {
		*(info->format) = next_format;
		*(info->object) = object;
		*(info->arguments) = arguments;
		*(info->num_arguments) = num_arguments;
	    }

	    /* everything seens fine, print the format directive */
	    switch (args->command) {
		case 'A':
		    head = lisp__data.env.length;
		    LispAddVar(Oprint_escape, NIL);
		    ++lisp__data.env.head;
		    format_ascii(stream, object, args);
		    lisp__data.env.head = lisp__data.env.length = head;
		    break;
		case 'S':
		    head = lisp__data.env.length;
		    LispAddVar(Oprint_escape, T);
		    ++lisp__data.env.head;
		    format_ascii(stream, object, args);
		    lisp__data.env.head = lisp__data.env.length = head;
		    break;
		case 'B':
		    format_in_radix(stream, object, 2, args);
		    break;
		case 'O':
		    format_in_radix(stream, object, 8, args);
		    break;
		case 'D':
		    format_in_radix(stream, object, 10, args);
		    break;
		case 'X':
		    format_in_radix(stream, object, 16, args);
		    break;
		case 'R':
		    /* if a single argument specified */
		    if (args->count)
			format_in_radix(stream, object, 0, args);
		    else
			format_radix_special(stream, object, args);
		    break;
		case 'P':
		    if (args->atsign) {
			if (FIXNUMP(object) && FIXNUM_VALUE(object) == 1)
			    LispWriteChar(stream, 'y');
			else
			    LispWriteStr(stream, "ies", 3);
		    }
		    else if (!FIXNUMP(object) || FIXNUM_VALUE(object) != 1)
			LispWriteChar(stream, 's');
		    break;
		case 'C':
		    format_character(stream, object, args);
		    break;
		case 'F':
		    format_fixed_float(stream, object, args);
		    break;
		case 'E':
		    format_exponential_float(stream, object, args);
		    break;
		case 'G':
		    format_general_float(stream, object, args);
		    break;
		case '$':
		    format_dollar_float(stream, object, args);
		    break;
		case '&':
		    if (LispGetColumn(stream) == 0)
			--args->arguments[0].value;
		case '%':
		    LispWriteChars(stream, '\n', args->arguments[0].value);
		    break;
		case '|':
		    LispWriteChars(stream, '\f', args->arguments[0].value);
		    break;
		case '~':
		    LispWriteChars(stream, '~', args->arguments[0].value);
		    break;
		case '\n':
		    if (!args->collon) {
			if (args->atsign)
			    LispWriteChar(stream, '\n');
			/* ignore newline and following spaces */
			while (*next_format && isspace(*next_format))
			    ++next_format;
		    }
		    break;
		case 'T':
		    format_tabulate(stream, args);
		    break;
		case '*':
		    format_goto(info);
		    break;
		case '?':
		    format_indirection(stream, object, info);
		    need_update = 1;
		    break;
		case '(':
		    format_case_conversion(stream, info);
		    /* next_format if far from what is set now */
		    next_format = *(info->format);
		    break;
		case '[':
		    format_conditional(stream, info);
		    /* next_format if far from what is set now */
		    next_format = *(info->format);
		    break;
		case '{':
		    format_iterate(stream, info);
		    /* next_format if far from what is set now */
		    next_format = *(info->format);
		    break;
		case '<':
		    format_justify(stream, info);
		    /* next_format if far from what is set now */
		    next_format = *(info->format);
		    break;
		case '^':
		    if (args->collon) {
			if (hash && num_arguments == 0) {
			    info->upandout = UPANDOUT_HASH;
			    goto format_up_and_out;
			}
			if (info->iteration &&
			    info->iteration == ITERATION_NORMAL)
			/* not exactly an error, but in this case,
			 * command is ignored */
			    break;
			info->upandout = UPANDOUT_COLLON;
			goto format_up_and_out;
		    }
		    else if (num_arguments == 0) {
			info->upandout = UPANDOUT_NORMAL;
			goto format_up_and_out;
		    }
		    break;
	    }

	    if (need_update) {
		object = *(info->object);
		arguments = *(info->arguments);
		num_arguments = *(info->num_arguments);
	    }

	    format = next_format;
	}
	else {
	    if (length >= sizeof(stk)) {
		LispWriteStr(stream, stk, length);
		length = 0;
	    }
	    stk[length++] = *format++;
	}
    }

    /* flush any peding output */
    if (length)
	LispWriteStr(stream, stk, length);

format_up_and_out:
    /* update for recursive call */
    *(info->format) = format;
    *(info->object) = object;
    *(info->arguments) = arguments;
    *(info->num_arguments) = num_arguments;
}

LispObj *
Lisp_Format(LispBuiltin *builtin)
/*
 format destination control-string &rest arguments
 */
{
    GC_ENTER();
    FmtInfo info;
    LispObj *object;
    char *control_string;
    int num_arguments;

    LispObj *stream, *format, *arguments;

    arguments = ARGUMENT(2);
    format = ARGUMENT(1);
    stream = ARGUMENT(0);

    /* check format and stream */
    CHECK_STRING(format);
    if (stream == NIL) {	/* return a string */
	stream = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
	GC_PROTECT(stream);
    }
    else if (stream == T ||	/* print directly to *standard-output* */
	     stream == STANDARD_OUTPUT)
	stream = NIL;
    else {
	CHECK_STREAM(stream);
	if (!stream->data.stream.writable)
	    LispDestroy("%s: stream %s is not writable",
			STRFUN(builtin), STROBJ(stream));
    }

    /* count number of arguments */
    for (object = arguments, num_arguments = 0; CONSP(object);
	 object = CDR(object), num_arguments++)
	;

    /* initialize plural/argument info */
    object = NIL;

    /* the format string */
    control_string = THESTR(format);

    /* arguments to recursive calls */
    info.args.base = control_string;
    info.base_arguments = arguments;
    info.total_arguments = num_arguments;
    info.format = &control_string;
    info.object = &object;
    info.arguments = &arguments;
    info.num_arguments = &num_arguments;
    info.iteration = 0;

    /* format arguments */
    LispFormat(stream, &info);

    /* if printing to stdout */
    if (stream == NIL)
	LispFflush(Stdout);
    /* else if printing to string-stream, return a string */
    else if (stream->data.stream.type == LispStreamString) {
	int length;
	char *string;

	string = LispGetSstring(SSTREAMP(stream), &length);
	stream = LSTRING(string, length);
    }

    GC_LEAVE();

    return (stream);
}