Logo Search packages:      
Sourcecode: xbase-clients version File versions  Download package

format.c

/*
 * 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, 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);
}

Generated by  Doxygen 1.6.0   Back to index