#include "lisp/io.h"
#include "lisp/write.h"
#include "lisp/format.h"
#include <ctype.h>
#define MAXFMT 8
#define NOERROR 0
#define PARSE_2MANYPARM 1
#define PARSE_2MANYATS 2
#define PARSE_2MANYCOLS 3
#define PARSE_NOARGSLEFT 4
#define PARSE_BADFMTARG 5
#define PARSE_BADDIRECTIVE 6
#define PARSE_BADINTEGER 7
#define MERGE_2MANY 1
#define MERGE_NOCHAR 2
#define MERGE_NOINT 3
#define GENERIC_RADIX 1
#define GENERIC_NEGATIVE 2
#define GENERIC_BADSTRING 3
#define GENERIC_BADLIST 4
#define IF_SPECIFIED(arg) (arg).specified ? &((arg).value) : NULL
#define UPANDOUT_NORMAL 1
#define UPANDOUT_COLLON 2
#define UPANDOUT_HASH 4
#define ITERATION_NORMAL 1
#define ITERATION_LAST 2
typedef struct {
unsigned int achar : 1;
unsigned int specified : 1;
unsigned int offset : 30;
int value;
} FmtArg;
typedef struct {
unsigned int atsign : 1;
unsigned int collon : 1;
unsigned int command : 8;
unsigned int count : 4;
unsigned int offset : 10;
char *base, *format;
FmtArg arguments[MAXFMT];
} FmtArgs;
typedef struct {
int achar;
int value;
} FmtDef;
typedef struct {
int count;
FmtDef defaults[MAXFMT];
} FmtDefs;
typedef struct {
FmtArgs args;
LispObj *base_arguments;
int total_arguments;
char **format;
LispObj **object;
LispObj **arguments;
int *num_arguments;
int upandout;
int iteration;
} FmtInfo;
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*);
static FmtDefs AsciiDefs = {
4,
{
{0, 0},
{0, 1},
{0, 0},
{1, ' '},
},
};
static FmtDefs IntegerDefs = {
4,
{
{0, 0},
{1, ' '},
{1, ','},
{0, 3},
},
};
static FmtDefs RadixDefs = {
5,
{
{0, 10},
{0, 0},
{1, ' '},
{1, ','},
{0, 3},
},
};
static FmtDefs NoneDefs = {
0,
};
static FmtDefs FixedFloatDefs = {
5,
{
{0, 0},
{0, 16},
{0, 0},
{1, '\0'},
{1, ' '},
},
};
static FmtDefs ExponentialFloatDefs = {
7,
{
{0, 0},
{0, 16},
{0, 0},
{0, 1},
{1, '\0'},
{1, ' '},
{1, 'E'},
},
};
static FmtDefs DollarFloatDefs = {
4,
{
{0, 2},
{0, 1},
{0, 0},
{1, ' '},
},
};
static FmtDefs OneDefs = {
1,
{
{0, 1},
},
};
static FmtDefs TabulateDefs = {
2,
{
{0, 0},
{0, 1},
},
};
extern LispObj *Oprint_escape;
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;
}
}
if (arguments->count > defaults->count)
*code = MERGE_2MANY;
}
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;
test = objects == NULL || code == NULL || num_objects == NULL;
ptr = format;
argument = &(arguments->arguments[0]);
arguments->atsign = arguments->collon = arguments->command = 0;
for (arguments->count = 0;; arguments->count++) {
arguments->offset = ptr - format + 1;
if (arguments->count >= MAXFMT) {
if (!test)
*code = PARSE_2MANYPARM;
return (ptr);
}
if (*ptr == '\'') {
++ptr;
argument->achar = argument->specified = 1;
argument->value = *ptr++;
}
else if (*ptr == ',') {
argument->achar = 0;
argument->specified = 0;
}
else if (*ptr == '#') {
++ptr;
argument->achar = 0;
argument->specified = 1;
if (!test)
argument->value = *num_objects;
}
else if (*ptr == 'v' ||
*ptr == 'V') {
LispObj *object;
++ptr;
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 == '+') {
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
break;
if (*ptr == ',')
++ptr;
argument->offset = arguments->offset;
argument++;
}
for (;;) {
if (*ptr == '@') {
if (arguments->atsign) {
if (!test) {
*code = PARSE_2MANYATS;
return (ptr);
}
}
++ptr;
++arguments->offset;
arguments->atsign = 1;
}
else if (*ptr == ':') {
if (arguments->collon) {
if (!test) {
*code = PARSE_2MANYCOLS;
return (ptr);
}
}
++ptr;
++arguments->offset;
arguments->collon = 1;
}
else
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;
formatlen = (args->format - args->base) + args->offset;
errorlen = strlen(str) + 1;
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;
if (mincol < 0)
mincol = 0;
if (colinc < 0)
colinc = 1;
if (minpad < 0)
minpad = 0;
if (object == NIL)
length = collon ? 2 : 3;
if (atsign) {
if (object == NIL) {
string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
GC_PROTECT(string);
length = LispWriteObject(string, object);
}
if (minpad) {
length += minpad;
LispWriteChars(stream, padchar, minpad);
}
if (colinc) {
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 == NIL)
length = format_object(stream, object);
else {
int size;
char *str = LispGetSstring(SSTREAMP(string), &size);
LispWriteStr(stream, str, size);
}
}
if (!atsign) {
if (minpad) {
length += minpad;
LispWriteChars(stream, padchar, minpad);
}
if (colinc) {
while (length < mincol) {
LispWriteChars(stream, padchar, colinc);
length += colinc;
}
}
}
GC_LEAVE();
}
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) {
if (colnum > 0) {
LispWriteChars(stream, ' ', colnum);
column += colnum;
}
if (colinc > 0)
LispWriteChars(stream, ' ', colinc - (column % colinc));
}
else {
if (colinc <= 0)
LispWriteChars(stream, ' ', column - colnum);
else {
do {
LispWriteChars(stream, ' ', colinc);
colnum -= colinc;
} while (colnum > column);
}
}
}
static void
format_goto(FmtInfo *info)
{
int count, num_arguments;
LispObj *object, *arguments;
count = info->args.arguments[0].value;
if (count < 0)
generic_error(&(info->args), GENERIC_NEGATIVE);
if (info->args.atsign) {
if (!(info->args.arguments[0].specified))
count = 0;
if (count > info->total_arguments)
parse_error(&(info->args), PARSE_NOARGSLEFT);
else if (count != info->total_arguments - *(info->num_arguments)) {
object = NIL;
arguments = info->base_arguments;
num_arguments = info->total_arguments - count;
for (; count > 0; count--, arguments = CDR(arguments))
object = CAR(arguments);
*(info->object) = object;
*(info->arguments) = arguments;
*(info->num_arguments) = num_arguments;
}
}
else if (count) {
arguments = *(info->arguments);
num_arguments = *(info->num_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 {
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);
}
*(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);
memcpy(&indirect_info, info, sizeof(FmtInfo));
indirect_info.args.base = indirect_info.args.format = string;
indirect_info.format = &string;
if (info->args.atsign) {
LispFormat(stream, &indirect_info);
}
else {
int num_arguments;
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);
*(info->object) = object;
*(info->arguments) = CDR(*(info->arguments));
*(info->num_arguments) -= 1;
indirect_info.base_arguments = object;
indirect_info.arguments = &object;
for (num_arguments = 0; CONSP(object); object = CDR(object))
++num_arguments;
object = indirect_info.base_arguments;
indirect_info.total_arguments = num_arguments;
indirect_info.num_arguments = &num_arguments;
LispFormat(stream, &indirect_info);
}
}
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)
{
FmtArgs args;
int counters[] = { 0, 0, 0, 0};
char *format, *next_format, *start, **formats;
int num_formats, format_index, separator, add_format;
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
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;
}
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;
if (add_format == LIST_FORMATS_DONE)
break;
else if (command == '[' && has_default != NULL)
*has_default = args.collon != 0;
else if (command == '<' && num_formats == 1) {
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;
}
if (counters[format_index] != 0) {
char error_message[64];
sprintf(error_message, "expecting ~%c", command);
format_error(&(info->args), error_message);
}
*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;
string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
GC_PROTECT(string);
memcpy(&case_info, info, sizeof(FmtInfo));
next_format = *(info->format);
list_formats(info, '(', &next_format, &formats, &num_formats,
NULL, NULL, NULL);
format = formats[0];
case_info.args.base = case_info.args.format = format;
case_info.format = &format;
LispFormat(string, &case_info);
str = ptr = LispGetSstring(SSTREAMP(string), &length);
if (!atsign && !collon) {
for (; *ptr; ptr++) {
if (isupper(*ptr))
*ptr = tolower(*ptr);
}
}
else if (atsign && collon) {
for (; *ptr; ptr++) {
if (islower(*ptr))
*ptr = toupper(*ptr);
}
}
else {
int upper = 1;
for (; *ptr; ptr++)
if (isalnum(*ptr))
break;
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;
}
}
LispWriteStr(stream, str, length);
GC_LEAVE();
free_formats(formats, num_formats);
*(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;
object = *(info->object);
arguments = *(info->arguments);
num_arguments = *(info->num_arguments);
choice = -1;
next_format = *(info->format);
list_formats(info, '[',
&next_format, &formats, &num_formats, &has_default, NULL, NULL);
if (info->args.collon) {
if (!CONSP(arguments))
parse_error(&(info->args), PARSE_NOARGSLEFT);
object = CAR(arguments);
arguments = CDR(arguments);
--num_arguments;
choice = object == NIL ? 0 : 1;
}
else if (info->args.atsign) {
if (!CONSP(arguments))
parse_error(&(info->args), PARSE_NOARGSLEFT);
if (CAR(arguments) != NIL)
choice = 0;
else {
object = CAR(arguments);
arguments = CDR(arguments);
--num_arguments;
}
}
else if (info->args.arguments[0].specified)
choice = info->args.arguments[0].value;
else {
if (!CONSP(arguments))
parse_error(&(info->args), PARSE_NOARGSLEFT);
object = CAR(arguments);
arguments = CDR(arguments);
--num_arguments;
if (FIXNUMP(object))
choice = FIXNUM_VALUE(object);
}
*(info->object) = object;
*(info->arguments) = arguments;
*(info->num_arguments) = num_arguments;
if (has_default && (choice < 0 || choice >= num_formats))
choice = num_formats - 1;
if (choice >= 0 && choice < num_formats) {
FmtInfo conditional_info;
memcpy(&conditional_info, info, sizeof(FmtInfo));
format = formats[choice];
conditional_info.args.base = conditional_info.args.format = format;
conditional_info.format = &format;
LispFormat(stream, &conditional_info);
}
free_formats(formats, num_formats);
*(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;
object = *(info->object);
arguments = *(info->arguments);
num_arguments = *(info->num_arguments);
iterate = has_min = 0;
next_format = *(info->format);
has_max = info->args.arguments[0].specified;
iterate_max = info->args.arguments[0].value;
list_formats(info, '{', &next_format, &formats, &num_formats,
NULL, NULL, NULL);
loop_format = formats[0];
memcpy(&iterate_info, info, sizeof(FmtInfo));
if (!info->args.atsign && !info->args.collon) {
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)) {
for (iobject = object; CONSP(iobject); iobject = CDR(iobject))
++inum_arguments;
}
else if (object != NIL)
generic_error(&(info->args), GENERIC_BADLIST);
iobject = NIL;
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;
for (;; iterate++) {
if (has_max && iterate > iterate_max)
break;
else if (inum_arguments == 0 && (!has_min || iterate > 0))
break;
format = loop_format;
iterate_info.args.base = iterate_info.args.format = format;
iterate_info.format = &format;
iterate_info.iteration = ITERATION_NORMAL;
LispFormat(stream, &iterate_info);
if (iterate_info.upandout & UPANDOUT_HASH)
break;
}
}
else if (info->args.atsign && info->args.collon) {
for (;; iterate++) {
if (has_max && iterate > iterate_max)
break;
else if (num_arguments == 0 && (!has_min || iterate > 0))
break;
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)) {
for (iobject = object; CONSP(iobject); iobject = CDR(iobject))
++inum_arguments;
}
else if (object != NIL)
generic_error(&(info->args), GENERIC_BADLIST);
iobject = NIL;
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;
iterate_info.args.base = iterate_info.args.format = format;
iterate_info.format = &format;
iterate_info.iteration =
num_arguments > 0 ? ITERATION_NORMAL : ITERATION_LAST;
LispFormat(stream, &iterate_info);
if (iterate_info.upandout & UPANDOUT_HASH)
break;
}
}
else if (info->args.collon) {
LispObj *sarguments, *sobject;
int snum_arguments;
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)) {
for (sobject = object; CONSP(sobject); sobject = CDR(sobject))
++snum_arguments;
}
else
generic_error(&(info->args), GENERIC_BADLIST);
for (;; iterate++) {
if (has_max && iterate > iterate_max)
break;
else if (snum_arguments == 0 && (!has_min || iterate > 0))
break;
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)) {
for (iobject = sobject; CONSP(iobject); iobject = CDR(iobject))
++inum_arguments;
}
else if (sobject != NIL)
generic_error(&(info->args), GENERIC_BADLIST);
iobject = NIL;
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;
iterate_info.args.base = iterate_info.args.format = format;
iterate_info.format = &format;
iterate_info.iteration =
snum_arguments > 0 ? ITERATION_NORMAL : ITERATION_LAST;
LispFormat(stream, &iterate_info);
if (iterate_info.upandout & UPANDOUT_HASH)
break;
}
}
else if (info->args.atsign) {
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 (has_max && iterate > iterate_max)
break;
else if (num_arguments == 0 && (!has_min || iterate > 0))
break;
format = loop_format;
iterate_info.args.base = iterate_info.args.format = format;
iterate_info.format = &format;
iterate_info.iteration = ITERATION_NORMAL;
LispFormat(stream, &iterate_info);
if (iterate_info.upandout & UPANDOUT_HASH)
break;
}
}
free_formats(formats, num_formats);
*(info->object) = object;
*(info->arguments) = arguments;
*(info->num_arguments) = num_arguments;
*(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(info, '<', &next_format, &formats, &num_formats,
&has_default, &comma_width, &line_width);
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);
}
}
memcpy(&justify_info, info, sizeof(FmtInfo));
for (i = 0, cons = strings; i < num_formats; i++, cons = CDR(cons)) {
format = formats[i];
justify_info.args.base = justify_info.args.format = format;
justify_info.format = &format;
LispFormat(CAR(cons), &justify_info);
if (justify_info.upandout)
RPLACA(cons, NIL);
if (justify_info.upandout & UPANDOUT_COLLON) {
for (cons = CDR(cons); i < num_formats; i++, cons = CDR(cons))
RPLACA(cons, NIL);
break;
}
}
free_formats(formats, num_formats);
if (CAR(strings) == NIL) {
while (CAR(strings) == NIL) {
strings = CDR(strings);
--num_formats;
}
lisp__data.protect.objects[gc__protect] = strings;
}
cons = strings;
while (CONSP(cons)) {
if (CONSP(CDR(cons)) && CAR(CDR(cons)) == NIL) {
RPLACD(cons, CDR(CDR(cons)));
--num_formats;
}
else
cons = CDR(cons);
}
if (has_default)
cons = CDR(strings);
else
cons = strings;
for (total_length = 0; CONSP(cons); cons = CDR(cons))
total_length += SSTREAMP(CAR(cons))->length;
if (has_default)
cons = CDR(strings);
else
cons = strings;
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) {
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);
}
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);
if (k && !atsign) {
LispWriteChars(stream, padchar, k);
k = 0;
}
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 (k)
LispWriteChars(stream, padchar, k);
}
else {
LispObj *result;
int last, spaces_before, padout;
if (has_default && line_width > 0 && comma_width >= 0) {
result = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
GC_PROTECT(result);
}
else
result = stream;
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) {
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 (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 (has_default && length + comma_width > line_width) {
str = LispGetSstring(SSTREAMP(CAR(strings)), &size);
LispWriteStr(stream, str, size);
}
str = LispGetSstring(SSTREAMP(result), &size);
LispWriteStr(stream, str, size);
}
}
GC_LEAVE();
*(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;
format = *(info->format);
object = *(info->object);
arguments = *(info->arguments);
num_arguments = *(info->num_arguments);
length = 0;
args = &(info->args);
info->upandout = 0;
while (*format) {
if (*format == '~') {
if (length) {
LispWriteStr(stream, stk, length);
length = 0;
}
need_argument = need_update = hash = 0;
args->format = format + 1;
next_format = parse_arguments(format + 1, args, &num_arguments,
&arguments, &code);
if (code != NOERROR)
parse_error(args, code);
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 ')':
format_error(args, "no match for directive ~)");
case '[':
defs = &OneDefs;
break;
case ']':
format_error(args, "no match for directive ~]");
case '{':
defs = &OneDefs;
break;
case '}':
format_error(args, "no match for directive ~}");
case '<':
defs = &AsciiDefs;
break;
case '>':
format_error(args, "no match for directive ~>");
case ';':
format_error(args, "misplaced directive ~;");
case '#':
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);
switch (args->command) {
case 'A': case 'S':
case 'B': case 'O': case 'D': case 'X': case 'R':
need_argument = 1;
break;
case 'P':
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 '*':
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;
}
if (need_update) {
*(info->format) = next_format;
*(info->object) = object;
*(info->arguments) = arguments;
*(info->num_arguments) = num_arguments;
}
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 (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');
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 = *(info->format);
break;
case '[':
format_conditional(stream, info);
next_format = *(info->format);
break;
case '{':
format_iterate(stream, info);
next_format = *(info->format);
break;
case '<':
format_justify(stream, info);
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)
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++;
}
}
if (length)
LispWriteStr(stream, stk, length);
format_up_and_out:
*(info->format) = format;
*(info->object) = object;
*(info->arguments) = arguments;
*(info->num_arguments) = num_arguments;
}
LispObj *
Lisp_Format(LispBuiltin *builtin)
{
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_STRING(format);
if (stream == NIL) {
stream = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
GC_PROTECT(stream);
}
else if (stream == T ||
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));
}
for (object = arguments, num_arguments = 0; CONSP(object);
object = CDR(object), num_arguments++)
;
object = NIL;
control_string = THESTR(format);
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;
LispFormat(stream, &info);
if (stream == NIL)
LispFflush(Stdout);
else if (stream->data.stream.type == LispStreamString) {
int length;
char *string;
string = LispGetSstring(SSTREAMP(stream), &length);
stream = LSTRING(string, length);
}
GC_LEAVE();
return (stream);
}