format.c revision f765521f 
1/*
2 * Copyright (c) 2002 by The XFree86 Project, Inc.
3 *
4 * Permission is hereby granted, free of charge, to any person obtaining a
5 * copy of this software and associated documentation files (the "Software"),
6 * to deal in the Software without restriction, including without limitation
7 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
8 * and/or sell copies of the Software, and to permit persons to whom the
9 * Software is furnished to do so, subject to the following conditions:
10 *
11 * The above copyright notice and this permission notice shall be included in
12 * all copies or substantial portions of the Software.
13 *
14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
17 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
18 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
19 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
20 * SOFTWARE.
21 *
22 * Except as contained in this notice, the name of the XFree86 Project shall
23 * not be used in advertising or otherwise to promote the sale, use or other
24 * dealings in this Software without prior written authorization from the
25 * XFree86 Project.
26 *
27 * Author: Paulo César Pereira de Andrade
28 */
29
30/* $XFree86: xc/programs/xedit/lisp/format.c,v 1.29tsi Exp $ */
31
32#include "lisp/io.h"
33#include "lisp/write.h"
34#include "lisp/format.h"
35#include <ctype.h>
36
37#define MAXFMT			8
38#define NOERROR			0
39
40/* parse error codes */
41#define PARSE_2MANYPARM		1	/* too many directive parameters */
42#define PARSE_2MANYATS		2	/* more than one @ in directive */
43#define PARSE_2MANYCOLS		3	/* more than one : in directive */
44#define PARSE_NOARGSLEFT	4	/* no arguments left to format */
45#define PARSE_BADFMTARG		5	/* argument is not an integer or char */
46#define PARSE_BADDIRECTIVE	6	/* unknown format directive */
47#define PARSE_BADINTEGER	7	/* bad integer representation */
48
49/* merge error codes */
50#define MERGE_2MANY		1	/* too many parameters to directive */
51#define MERGE_NOCHAR		2	/* parameter must be a character */
52#define MERGE_NOINT		3	/* parameter must be an integer */
53
54/* generic error codes */
55#define GENERIC_RADIX		1	/* radix not in range 2-36 */
56#define GENERIC_NEGATIVE	2	/* parameter is negative */
57#define GENERIC_BADSTRING	3	/* argument is not a string */
58#define GENERIC_BADLIST		4	/* argument is not a list */
59
60#define IF_SPECIFIED(arg)	(arg).specified ? &((arg).value) : NULL
61
62#define UPANDOUT_NORMAL		1
63#define UPANDOUT_COLLON		2
64#define UPANDOUT_HASH		4	/* only useful inside a ~{ iteration
65					 * forces loop finalization. */
66
67#define ITERATION_NORMAL	1
68#define ITERATION_LAST		2
69
70/*
71 * Types
72 */
73/* parameter to format */
74typedef struct {
75    unsigned int achar : 1;	/* value was specified as a character */
76    unsigned int specified : 1;	/* set if value was specified */
77    unsigned int offset : 30;	/* offset in format string, for error printing */
78    int value;
79} FmtArg;
80
81/* information about format parameters */
82typedef struct {
83    unsigned int atsign : 1;	/* @ specified */
84    unsigned int collon : 1;	/* : specified */
85    unsigned int command : 8;	/* the format command */
86    unsigned int count : 4;	/* number of arguments processed */
87    unsigned int offset : 10;	/* offset in format string, for error printing */
88    char *base, *format;
89    FmtArg arguments[MAXFMT];
90} FmtArgs;
91
92/* used for combining default format parameter values */
93typedef struct {
94    int achar;
95    int value;
96} FmtDef;
97
98/* number of default format parameter values and defaults */
99typedef struct {
100    int count;
101    FmtDef defaults[MAXFMT];
102} FmtDefs;
103
104/* used on recursive calls to LispFormat */
105typedef struct {
106    FmtArgs args;
107    LispObj *base_arguments;	/* pointer to first format argument */
108    int total_arguments;	/* number of objects in base_arguments */
109    char **format;		/* if need to update format string pointer */
110    LispObj **object;		/* CAR(arguments), for plural check */
111    LispObj **arguments;	/* current element of base_arguments */
112    int *num_arguments;		/* number of arguments after arguments */
113    int upandout;		/* information for recursive calls */
114    int iteration;		/* only set if in ~:{... or ~:@{ and in the
115				 * last argument list, hint for upandout */
116} FmtInfo;
117
118/*
119 * Prototypes
120 */
121static void merge_arguments(FmtArgs*, const FmtDefs*, int*);
122static char *parse_arguments(char*, FmtArgs*, int*, LispObj**, int*);
123static void merge_error(FmtArgs*, int);
124static void parse_error(FmtArgs*, int);
125static void generic_error(FmtArgs*, int);
126static void format_error(FmtArgs*, const char*);
127
128static int format_object(LispObj*, LispObj*);
129
130static void format_ascii(LispObj*, LispObj*, FmtArgs*);
131static void format_in_radix(LispObj*, LispObj*, int, FmtArgs*);
132static void format_radix_special(LispObj*, LispObj*, FmtArgs*);
133static void format_roman(LispObj*, LispObj*, FmtArgs*);
134static void format_english(LispObj*, LispObj*, FmtArgs*);
135static void format_character(LispObj*, LispObj*, FmtArgs*);
136static void format_fixed_float(LispObj*, LispObj*, FmtArgs*);
137static void format_exponential_float(LispObj*, LispObj*, FmtArgs*);
138static void format_general_float(LispObj*, LispObj*, FmtArgs*);
139static void format_dollar_float(LispObj*, LispObj*, FmtArgs*);
140static void format_tabulate(LispObj*, FmtArgs*);
141
142static void format_goto(FmtInfo*);
143static void format_indirection(LispObj*, LispObj*, FmtInfo*);
144
145static void list_formats(FmtInfo*, int, char**, char***, int*, int*, int*, int*);
146static void free_formats(char**, int);
147
148static void format_case_conversion(LispObj*, FmtInfo*);
149static void format_conditional(LispObj*, FmtInfo*);
150static void format_iterate(LispObj*, FmtInfo*);
151static void format_justify(LispObj*, FmtInfo*);
152
153static void LispFormat(LispObj*, FmtInfo*);
154
155/*
156 * Initialization
157 */
158static const FmtDefs AsciiDefs = {
159    4,
160    {
161	{0, 0},			/* mincol */
162	{0, 1},			/* colinc */
163	{0, 0},			/* minpad */
164	{1, ' '},		/* padchar */
165    },
166};
167
168static const FmtDefs IntegerDefs = {
169    4,
170    {
171	{0, 0},			/* mincol */
172	{1, ' '},		/* padchar */
173	{1, ','},		/* commachar */
174	{0, 3},			/* commainterval */
175    },
176};
177
178static const FmtDefs RadixDefs = {
179    5,
180    {
181	{0, 10},		/* radix */
182	{0, 0},			/* mincol */
183	{1, ' '},		/* padchar */
184	{1, ','},		/* commachar */
185	{0, 3},			/* commainterval */
186    },
187};
188
189static const FmtDefs NoneDefs = {
190    0,
191};
192
193static const FmtDefs FixedFloatDefs = {
194    5,
195    {
196	{0, 0},			/* w */
197	{0, 16},		/* d */
198	{0, 0},			/* k */
199	{1, '\0'},		/* overflowchar */
200	{1, ' '},		/* padchar */
201    },
202};
203
204static const FmtDefs ExponentialFloatDefs = {
205    7,
206    {
207	{0, 0},			/* w */
208	{0, 16},		/* d */
209	{0, 0},			/* e */
210	{0, 1},			/* k */
211	{1, '\0'},		/* overflowchar */
212	{1, ' '},		/* padchar */
213	{1, 'E'},		/* exponentchar */
214	/* XXX if/when more than one float format,
215	 * should default to object type */
216    },
217};
218
219static const FmtDefs DollarFloatDefs = {
220    4,
221    {
222	{0, 2},			/* d */
223	{0, 1},			/* n */
224	{0, 0},			/* w */
225	{1, ' '},		/* padchar */
226    },
227};
228
229static const FmtDefs OneDefs = {
230    1,
231    {
232	{0, 1},
233    },
234};
235
236static const FmtDefs TabulateDefs = {
237    2,
238    {
239	{0, 0},			/* colnum */
240	{0, 1},			/* colinc */
241    },
242};
243
244extern LispObj *Oprint_escape;
245
246/*
247 * Implementation
248 */
249static void
250merge_arguments(FmtArgs *arguments, const FmtDefs *defaults, int *code)
251{
252    int count;
253    const FmtDef *defaul;
254    FmtArg *argument;
255
256    defaul = &(defaults->defaults[0]);
257    argument = &(arguments->arguments[0]);
258    for (count = 0; count < defaults->count; count++, argument++, defaul++) {
259	if (count >= arguments->count)
260	    argument->specified = 0;
261	if (argument->specified) {
262	    if (argument->achar != defaul->achar) {
263		*code = defaul->achar ? MERGE_NOCHAR : MERGE_NOINT;
264		arguments->offset = argument->offset;
265		return;
266	    }
267	}
268	else {
269	    argument->specified = 0;
270	    argument->achar = defaul->achar;
271	    argument->value = defaul->value;
272	}
273    }
274
275    /* check if extra arguments were provided */
276    if (arguments->count > defaults->count)
277	*code = MERGE_2MANY;
278}
279
280/* the pointer arguments may be null, useful when just testing/parsing
281 * the directive parameters */
282static char *
283parse_arguments(char *format, FmtArgs *arguments,
284		int *num_objects, LispObj **objects, int *code)
285{
286    int test;
287    char *ptr;
288    FmtArg *argument;
289    unsigned int tmpcmd = 0;
290
291    /* initialize */
292    test = objects == NULL || code == NULL || num_objects == NULL;
293    ptr = format;
294    argument = &(arguments->arguments[0]);
295    arguments->atsign = arguments->collon = arguments->command = 0;
296
297    /* parse format parameters */
298    for (arguments->count = 0;; arguments->count++) {
299	arguments->offset = ptr - format + 1;
300	if (arguments->count >= MAXFMT) {
301	    if (!test)
302		*code = PARSE_2MANYPARM;
303	    return (ptr);
304	}
305	if (*ptr == '\'') {		/* character parameter value */
306	    ++ptr;			/* skip ' */
307	    argument->achar = argument->specified = 1;
308	    argument->value = *ptr++;
309	}
310	else if (*ptr == ',') {		/* use default parameter value */
311	    argument->achar = 0;
312	    argument->specified = 0;
313	    /* don't increment ptr, will be incremented below */
314	}
315	else if (*ptr == '#') {		/* number of arguments is value */
316	    ++ptr;			/* skip # */
317	    argument->achar = 0;
318	    argument->specified = 1;
319	    if (!test)
320		argument->value = *num_objects;
321	}
322	else if (*ptr == 'v' ||
323		 *ptr == 'V') {		/* format object argument is value */
324	    LispObj *object;
325
326	    ++ptr;			/* skip V */
327	    if (!test) {
328		if (!CONSP(*objects)) {
329		    *code = PARSE_NOARGSLEFT;
330		    return (ptr);
331		}
332		object = CAR((*objects));
333		if (FIXNUMP(object)) {
334		    argument->achar = 0;
335		    argument->specified = 1;
336		    argument->value = FIXNUM_VALUE(object);
337		}
338		else if (SCHARP(object)) {
339		    argument->achar = argument->specified = 1;
340		    argument->value = SCHAR_VALUE(object);
341		}
342		else {
343		    *code = PARSE_BADFMTARG;
344		    return (ptr);
345		}
346		*objects = CDR(*objects);
347		--*num_objects;
348	    }
349	}
350	else if (isdigit(*ptr) ||
351		*ptr == '-' || *ptr == '+') {	/* integer parameter value */
352	    int sign;
353
354	    argument->achar = 0;
355	    argument->specified = 1;
356	    if (!isdigit(*ptr)) {
357		sign = *ptr++ == '-';
358	    }
359	    else
360		sign = 0;
361	    if (!test && !isdigit(*ptr)) {
362		*code = PARSE_BADINTEGER;
363		return (ptr);
364	    }
365	    argument->value = *ptr++ - '0';
366	    while (isdigit(*ptr)) {
367		argument->value = (argument->value * 10) + (*ptr++ - '0');
368		if (argument->value > 65536) {
369		    if (!test) {
370			*code = PARSE_BADINTEGER;
371			return (ptr);
372		    }
373		}
374	    }
375	    if (sign)
376		argument->value = -argument->value;
377	}
378	else				/* no more arguments to format */
379	    break;
380
381	if (*ptr == ',')
382	    ++ptr;
383
384	/* remember offset of format parameter, for better error printing */
385	argument->offset = arguments->offset;
386	argument++;
387    }
388
389    /* check for extra flags */
390    for (;;) {
391	if (*ptr == '@') {		/* check for special parameter atsign */
392	    if (arguments->atsign) {
393		if (!test) {
394		    *code = PARSE_2MANYATS;
395		    return (ptr);
396		}
397	    }
398	    ++ptr;
399	    ++arguments->offset;
400	    arguments->atsign = 1;
401	}
402	else if (*ptr == ':') {		/* check for special parameter collon */
403	    if (arguments->collon) {
404		if (!test) {
405		    *code = PARSE_2MANYCOLS;
406		    return (ptr);
407		}
408	    }
409	    ++ptr;
410	    ++arguments->offset;
411	    arguments->collon = 1;
412	}
413	else				/* next value is format command */
414	    break;
415    }
416
417    if (!test)
418	*code = NOERROR;
419    arguments->command = *ptr++;
420    tmpcmd = arguments->command;
421    if (islower(tmpcmd))
422	arguments->command = toupper(tmpcmd);
423    ++arguments->offset;
424
425    return (ptr);
426}
427
428static void
429parse_error(FmtArgs *args, int code)
430{
431    static const char * const errors[] = {
432	NULL,
433	"too many parameters to directive",
434	"too many @ parameters",
435	"too many : parameters",
436	"no arguments left to format",
437	"argument is not a fixnum integer or a character",
438	"unknown format directive",
439	"parameter is not a fixnum integer",
440    };
441
442    format_error(args, errors[code]);
443}
444
445static void
446merge_error(FmtArgs *args, int code)
447{
448    static const char * const errors[] = {
449	NULL,
450	"too many parameters to directive",
451	"argument must be a character",
452	"argument must be a fixnum integer",
453    };
454
455    format_error(args, errors[code]);
456}
457
458static void
459generic_error(FmtArgs *args, int code)
460{
461    static const char * const errors[] = {
462	NULL,
463	"radix must be in the range 2 to 36, inclusive",
464	"parameter must be positive",
465	"argument must be a string",
466	"argument must be a list",
467    };
468
469    format_error(args, errors[code]);
470}
471
472static void
473format_error(FmtArgs *args, const char *str)
474{
475    char *message;
476    int errorlen, formatlen;
477
478    /* number of bytes of format to be printed */
479    formatlen = (args->format - args->base) + args->offset;
480
481    /* length of specific error message */
482    errorlen = strlen(str) + 1;			/* plus '\n' */
483
484    /* XXX allocate string with LispMalloc,
485     * so that it will be freed in LispTopLevel */
486    message = LispMalloc(formatlen + errorlen + 1);
487
488    sprintf(message, "%s\n", str);
489    memcpy(message + errorlen, args->base, formatlen);
490    message[errorlen + formatlen] = '\0';
491
492    LispDestroy("FORMAT: %s", message);
493}
494
495static int
496format_object(LispObj *stream, LispObj *object)
497{
498    int length;
499
500    length = LispWriteObject(stream, object);
501
502    return (length);
503}
504
505static void
506format_ascii(LispObj *stream, LispObj *object, FmtArgs *args)
507{
508    GC_ENTER();
509    LispObj *string = NIL;
510    int length = 0,
511	atsign = args->atsign,
512	collon = args->collon,
513	mincol = args->arguments[0].value,
514	colinc = args->arguments[1].value,
515	minpad = args->arguments[2].value,
516	padchar = args->arguments[3].value;
517
518    /* check/correct arguments */
519    if (mincol < 0)
520	mincol = 0;
521    if (colinc < 0)
522	colinc = 1;
523    if (minpad < 0)
524	minpad = 0;
525    /* XXX pachar can be the null character? */
526
527    if (object == NIL)
528	length = collon ? 2 : 3;	    /* () or NIL */
529
530    /* left padding */
531    if (atsign) {
532	/* if length not yet known */
533	if (object == NIL) {
534	    string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
535	    GC_PROTECT(string);
536	    length = LispWriteObject(string, object);
537	}
538
539	/* output minpad characters at left */
540	if (minpad) {
541	    length += minpad;
542	    LispWriteChars(stream, padchar, minpad);
543	}
544
545	if (colinc) {
546	    /* puts colinc spaces at a time,
547	     * until at least mincol chars out */
548	    while (length < mincol) {
549		LispWriteChars(stream, padchar, colinc);
550		length += colinc;
551	    }
552	}
553    }
554
555    if (object == NIL) {
556	if (collon)
557	    LispWriteStr(stream, "()", 2);
558	else
559	    LispWriteStr(stream,  Snil->value, 3);
560    }
561    else {
562	/* if string is not NIL, atsign was specified
563	 * and object printed to string */
564	if (string == NIL)
565	    length = format_object(stream, object);
566	else {
567	    int size;
568	    const char *str = LispGetSstring(SSTREAMP(string), &size);
569
570	    LispWriteStr(stream, str, size);
571	}
572    }
573
574    /* right padding */
575    if (!atsign) {
576	/* output minpad characters at left */
577	if (minpad) {
578	    length += minpad;
579	    LispWriteChars(stream, padchar, minpad);
580	}
581	if (colinc) {
582	    /* puts colinc spaces at a time,
583	     * until at least mincol chars out */
584	    while (length < mincol) {
585		LispWriteChars(stream, padchar, colinc);
586		length += colinc;
587	    }
588	}
589    }
590
591    GC_LEAVE();
592}
593
594/* assumes radix is 0 or in range 2 - 36 */
595static void
596format_in_radix(LispObj *stream, LispObj *object, int radix, FmtArgs *args)
597{
598    if (INTEGERP(object)) {
599	int i, atsign, collon, mincol, padchar, commachar, commainterval;
600
601	i = (radix == 0);
602	atsign = args->atsign;
603	collon = args->collon;
604	if (radix == 0) {
605	    radix = args->arguments[0].value;
606	    if (radix < 2 || radix > 36) {
607		args->offset = args->arguments[0].offset;
608		generic_error(args, GENERIC_RADIX);
609	    }
610	}
611	mincol = args->arguments[i++].value;
612	padchar = args->arguments[i++].value;
613	commachar = args->arguments[i++].value;
614	commainterval = args->arguments[i++].value;
615
616	LispFormatInteger(stream, object, radix, atsign, collon,
617			  mincol, padchar, commachar, commainterval);
618    }
619    else
620	format_object(stream, object);
621}
622
623static void
624format_radix_special(LispObj *stream, LispObj *object, FmtArgs *args)
625{
626    if (FIXNUMP(object)) {
627	if (args->atsign)
628	    format_roman(stream, object, args);
629	else
630	    format_english(stream, object, args);
631    }
632    else
633	format_object(stream, object);
634}
635
636static void
637format_roman(LispObj *stream, LispObj *object, FmtArgs *args)
638{
639    long value = 0;
640    int cando, new_roman = args->collon == 0;
641
642    if (FIXNUMP(object)) {
643	value = FIXNUM_VALUE(object);
644	if (new_roman)
645	    cando = value >= 1 && value <= 3999;
646	else
647	    cando = value >= 1 && value <= 4999;
648    }
649    else
650	cando = 0;
651
652    if (cando)
653	LispFormatRomanInteger(stream, value, new_roman);
654    else
655	format_object(stream, object);
656}
657
658static void
659format_english(LispObj *stream, LispObj *object, FmtArgs *args)
660{
661    int cando;
662    long number = 0;
663
664    if (FIXNUMP(object)) {
665	number = FIXNUM_VALUE(object);
666	cando = number >= -999999999 && number <= 999999999;
667    }
668    else
669	cando = 0;
670
671    if (cando)
672	LispFormatEnglishInteger(stream, number, args->collon);
673    else
674	format_object(stream, object);
675}
676
677static void
678format_character(LispObj *stream, LispObj *object, FmtArgs *args)
679{
680    if (SCHARP(object))
681	LispFormatCharacter(stream, object, args->atsign, args->collon);
682    else
683	format_object(stream, object);
684}
685
686static void
687format_fixed_float(LispObj *stream, LispObj *object, FmtArgs *args)
688{
689    if (FLOATP(object))
690	LispFormatFixedFloat(stream, object, args->atsign,
691			     args->arguments[0].value,
692			     IF_SPECIFIED(args->arguments[1]),
693			     args->arguments[2].value,
694			     args->arguments[3].value,
695			     args->arguments[4].value);
696    else
697	format_object(stream, object);
698}
699
700static void
701format_exponential_float(LispObj *stream, LispObj *object, FmtArgs *args)
702{
703    if (FLOATP(object))
704	LispFormatExponentialFloat(stream, object, args->atsign,
705				   args->arguments[0].value,
706				   IF_SPECIFIED(args->arguments[1]),
707				   args->arguments[2].value,
708				   args->arguments[3].value,
709				   args->arguments[4].value,
710				   args->arguments[5].value,
711				   args->arguments[6].value);
712    else
713	format_object(stream, object);
714}
715
716static void
717format_general_float(LispObj *stream, LispObj *object, FmtArgs *args)
718{
719    if (FLOATP(object))
720	LispFormatGeneralFloat(stream, object, args->atsign,
721				args->arguments[0].value,
722				IF_SPECIFIED(args->arguments[1]),
723				args->arguments[2].value,
724				args->arguments[3].value,
725				args->arguments[4].value,
726				args->arguments[5].value,
727				args->arguments[6].value);
728    else
729	format_object(stream, object);
730}
731
732static void
733format_dollar_float(LispObj *stream, LispObj *object, FmtArgs *args)
734{
735    if (FLOATP(object))
736	LispFormatDollarFloat(stream, object,
737			      args->atsign, args->collon,
738			      args->arguments[0].value,
739			      args->arguments[1].value,
740			      args->arguments[2].value,
741			      args->arguments[3].value);
742    else
743	format_object(stream, object);
744}
745
746static void
747format_tabulate(LispObj *stream, FmtArgs *args)
748{
749    int atsign = args->atsign,
750	colnum = args->arguments[0].value,
751	colinc = args->arguments[1].value,
752	column;
753
754    column = LispGetColumn(stream);
755
756    if (atsign) {
757	/* relative tabulation */
758	if (colnum > 0) {
759	    LispWriteChars(stream, ' ', colnum);
760	    column += colnum;
761	}
762	/* tabulate until at a multiple of colinc */
763	if (colinc > 0)
764	    LispWriteChars(stream, ' ', colinc - (column % colinc));
765    }
766    else {
767	/* if colinc not specified, just move to given column */
768	if (colinc <= 0)
769	    LispWriteChars(stream, ' ', column - colnum);
770	else {
771	    /* always output at least colinc spaces */
772	    do {
773		LispWriteChars(stream, ' ', colinc);
774		colnum -= colinc;
775	    } while (colnum > column);
776	}
777    }
778}
779
780static void
781format_goto(FmtInfo *info)
782{
783    int count, num_arguments;
784    LispObj *object, *arguments;
785
786    /* number of arguments to ignore or goto offset */
787    count = info->args.arguments[0].value;
788    if (count < 0)
789	generic_error(&(info->args), GENERIC_NEGATIVE);
790
791    if (info->args.atsign) {
792	/* absolute goto */
793
794	/* if not specified, defaults to zero */
795	if (!(info->args.arguments[0].specified))
796	    count = 0;
797
798	/* if offset too large */
799	if (count > info->total_arguments)
800	    parse_error(&(info->args), PARSE_NOARGSLEFT);
801	else if (count != info->total_arguments - *(info->num_arguments)) {
802	    /* calculate new parameters */
803	    object = NIL;
804	    arguments = info->base_arguments;
805	    num_arguments = info->total_arguments - count;
806
807	    for (; count > 0; count--, arguments = CDR(arguments))
808		object = CAR(arguments);
809
810	    /* update format information */
811	    *(info->object) = object;
812	    *(info->arguments) = arguments;
813	    *(info->num_arguments) = num_arguments;
814	}
815    }
816    else if (count) {
817	/* relative goto, ignore or go back count arguments */
818
819	/* prepare to update parameters */
820	arguments = *(info->arguments);
821	num_arguments = *(info->num_arguments);
822
823	/* go back count arguments? */
824	if (info->args.collon)
825	    count = -count;
826
827	num_arguments -= count;
828
829	if (count > 0) {
830	    if (count > *(info->num_arguments))
831		parse_error(&(info->args), PARSE_NOARGSLEFT);
832
833	    object = *(info->object);
834	    for (; count > 0; count--, arguments = CDR(arguments))
835		object = CAR(arguments);
836	}
837	else {		/* count < 0 */
838	    if (info->total_arguments + count - *(info->num_arguments) < 0)
839		parse_error(&(info->args), PARSE_NOARGSLEFT);
840
841	    object = NIL;
842	    arguments = info->base_arguments;
843	    for (count = 0; count < info->total_arguments - num_arguments;
844		count++, arguments = CDR(arguments))
845		object = CAR(arguments);
846	}
847
848	/* update format parameters */
849	*(info->object) = object;
850	*(info->arguments) = arguments;
851	*(info->num_arguments) = num_arguments;
852    }
853}
854
855static void
856format_indirection(LispObj *stream, LispObj *format, FmtInfo *info)
857{
858    char *string;
859    LispObj *object;
860    FmtInfo indirect_info;
861
862    if (!STRINGP(format))
863	generic_error(&(info->args), GENERIC_BADSTRING);
864    string = THESTR(format);
865
866    /* most information is the same */
867    memcpy(&indirect_info, info, sizeof(FmtInfo));
868
869    /* set new format string */
870    indirect_info.args.base = indirect_info.args.format = string;
871    indirect_info.format = &string;
872
873    if (info->args.atsign) {
874	/* use current arguments */
875
876	/* do the indirect format */
877	LispFormat(stream, &indirect_info);
878    }
879    else {
880	/* next argument is the recursive call arguments */
881
882	int num_arguments;
883
884	/* it is valid to not have a list following string, as string may
885	 * not have format directives */
886	if (CONSP(*(indirect_info.arguments)))
887	    object = CAR(*(indirect_info.arguments));
888	else
889	    object = NIL;
890
891	if (!LISTP(object) || !CONSP(*(info->arguments)))
892	    generic_error(&(info->args), GENERIC_BADLIST);
893
894	/* update information now */
895	*(info->object) = object;
896	*(info->arguments) = CDR(*(info->arguments));
897	*(info->num_arguments) -= 1;
898
899	/* set arguments for recursive call */
900	indirect_info.base_arguments = object;
901	indirect_info.arguments = &object;
902	for (num_arguments = 0; CONSP(object); object = CDR(object))
903	    ++num_arguments;
904
905	/* note that indirect_info.arguments is a pointer to "object",
906	 * keep it pointing to the correct object */
907	object = indirect_info.base_arguments;
908	indirect_info.total_arguments = num_arguments;
909	indirect_info.num_arguments = &num_arguments;
910
911	/* do the indirect format */
912	LispFormat(stream, &indirect_info);
913    }
914}
915
916/* update pointers to a list of format strings:
917 *	for '(' and '{' only one list is required
918 *	for '[' and '<' more than one may be returned
919 *	has_default is only meaningful for '[' and '<'
920 *	comma_width and line_width are only meaningful to '<', and
921 *	    only valid if has_default set
922 * if the string is finished prematurely, LispDestroy is called
923 * format_ptr is updated to the correct pointer in the "main" format string
924 */
925static void
926list_formats(FmtInfo *info, int command, char **format_ptr,
927	     char ***format_list, int *format_count, int *has_default,
928	     int *comma_width, int *line_width)
929{
930    /* instead of processing the directives recursively, just separate the
931     * input formats in separate strings, then see if one of then need to
932     * be used */
933    FmtArgs args;
934    int counters[] = {  0,   0,   0,   0};
935		    /* '[', '(', '{', '<' */
936    char *format, *next_format, *start, **formats;
937    int num_formats, format_index, separator, add_format;
938
939    /* initialize */
940    formats = NULL;
941    num_formats = format_index = 0;
942    if (has_default != NULL)
943	*has_default = 0;
944    if (comma_width != NULL)
945	*comma_width = 0;
946    if (line_width != NULL)
947	*line_width = 0;
948    format = start = next_format = *format_ptr;
949    switch (command) {
950	case '[': counters[0] = 1; format_index = 0; break;
951	case '(': counters[1] = 1; format_index = 1; break;
952	case '{': counters[2] = 1; format_index = 2; break;
953	case '<': counters[3] = 1; format_index = 3; break;
954    }
955
956#define	LIST_FORMATS_ADD	1
957#define	LIST_FORMATS_DONE	2
958
959    /* fill list of format options to conditional */
960    while (*format) {
961	if (*format == '~') {
962	    separator = add_format = 0;
963	    args.format = format + 1;
964	    next_format = parse_arguments(format + 1, &args, NULL, NULL, NULL);
965	    switch (args.command) {
966 		case '[': ++counters[0];    break;
967		case ']': --counters[0];    break;
968		case '(': ++counters[1];    break;
969		case ')': --counters[1];    break;
970		case '{': ++counters[2];    break;
971		case '}': --counters[2];    break;
972		case '<': ++counters[3];    break;
973		case '>': --counters[3];    break;
974		case ';': separator = 1;    break;
975	    }
976
977	    /* check if a new format string must be added */
978	    if (separator && counters[format_index] == 1 &&
979		(command == '[' || command == '<'))
980		add_format = LIST_FORMATS_ADD;
981	    else if (counters[format_index] == 0)
982		add_format = LIST_FORMATS_DONE;
983
984	    if (add_format) {
985		int length = format - start;
986
987		formats = LispRealloc(formats,
988				      (num_formats + 1) * sizeof(char*));
989
990		formats[num_formats] = LispMalloc(length + 1);
991		strncpy(formats[num_formats], start, length);
992		formats[num_formats][length] = '\0';
993		++num_formats;
994		/* loop finished? */
995		if (add_format == LIST_FORMATS_DONE)
996		    break;
997		else if (command == '[' && has_default != NULL)
998		    /* will be set only for the last parameter, what is
999		     * expected, just don't warn about it in the incorrect
1000		     * place */
1001		    *has_default = args.collon != 0;
1002		else if (command == '<' && num_formats == 1) {
1003		    /* if the first parameter to '<', there may be overrides
1004		     * to comma-width and line-width */
1005		    if (args.collon && has_default != NULL) {
1006			*has_default = 1;
1007			if (comma_width != NULL &&
1008			    args.arguments[0].specified &&
1009			    !args.arguments[0].achar)
1010			    *comma_width = args.arguments[0].value;
1011			if (line_width != NULL &&
1012			    args.arguments[1].specified &&
1013			    !args.arguments[1].achar)
1014			    *line_width = args.arguments[1].value;
1015		    }
1016		}
1017		start = next_format;
1018	    }
1019	    format = next_format;
1020	}
1021	else
1022	    ++format;
1023    }
1024
1025    /* check if format string did not finish prematurely */
1026    if (counters[format_index] != 0) {
1027	char error_message[64];
1028
1029	sprintf(error_message, "expecting ~%c", command);
1030	format_error(&(info->args), error_message);
1031    }
1032
1033    /* update pointers */
1034    *format_list = formats;
1035    *format_count = num_formats;
1036    *format_ptr = next_format;
1037}
1038
1039static void
1040free_formats(char **formats, int num_formats)
1041{
1042    if (num_formats) {
1043	while (--num_formats >= 0)
1044	    LispFree(formats[num_formats]);
1045	LispFree(formats);
1046    }
1047}
1048
1049static void
1050format_case_conversion(LispObj *stream, FmtInfo *info)
1051{
1052    GC_ENTER();
1053    LispObj *string;
1054    FmtInfo case_info;
1055    char *str, *ptr;
1056    char *format, *next_format, **formats;
1057    int atsign, collon, num_formats, length;
1058
1059    atsign = info->args.atsign;
1060    collon = info->args.collon;
1061
1062    /* output to a string, before case conversion */
1063    string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
1064    GC_PROTECT(string);
1065
1066    /* most information is the same */
1067    memcpy(&case_info, info, sizeof(FmtInfo));
1068
1069    /* list formats */
1070    next_format = *(info->format);
1071    list_formats(info, '(', &next_format, &formats, &num_formats,
1072		 NULL, NULL, NULL);
1073
1074    /* set new format string */
1075    format = formats[0];
1076    case_info.args.base = case_info.args.format = format;
1077    case_info.format = &format;
1078
1079    /* format text to string */
1080    LispFormat(string, &case_info);
1081
1082    str = ptr = LispGetSstring(SSTREAMP(string), &length);
1083
1084    /* do case conversion */
1085    if (!atsign && !collon) {
1086	/* convert all upercase to lowercase */
1087	for (; *ptr; ptr++) {
1088	    if (isupper(*ptr))
1089		*ptr = tolower(*ptr);
1090	}
1091    }
1092    else if (atsign && collon) {
1093	/* convert all lowercase to upercase */
1094	for (; *ptr; ptr++) {
1095	    if (islower(*ptr))
1096		*ptr = toupper(*ptr);
1097	}
1098    }
1099    else {
1100	int upper = 1;
1101
1102	/* skip non-alphanumeric characters */
1103	for (; *ptr; ptr++)
1104	    if (isalnum(*ptr))
1105		break;
1106
1107	/* capitalize words */
1108	for (; *ptr; ptr++) {
1109	    if (isalnum(*ptr)) {
1110		if (upper) {
1111		    if (islower(*ptr))
1112			*ptr = toupper(*ptr);
1113		    upper = 0;
1114		}
1115		else if (isupper(*ptr))
1116		    *ptr = tolower(*ptr);
1117	    }
1118	    else
1119		upper = collon;
1120		/* if collon, capitalize all words, else just first word */
1121	}
1122    }
1123
1124    /* output case converted string */
1125    LispWriteStr(stream, str, length);
1126
1127    /* temporary string stream is not necessary anymore */
1128    GC_LEAVE();
1129
1130    /* free temporary memory */
1131    free_formats(formats, num_formats);
1132
1133    /* this information always updated */
1134    *(info->format) = next_format;
1135}
1136
1137static void
1138format_conditional(LispObj *stream, FmtInfo *info)
1139{
1140    LispObj *object, *arguments;
1141    char *format, *next_format, **formats;
1142    int choice, num_formats, has_default, num_arguments;
1143
1144    /* save information that may change */
1145    object = *(info->object);
1146    arguments = *(info->arguments);
1147    num_arguments = *(info->num_arguments);
1148
1149    /* initialize */
1150    choice = -1;
1151    next_format = *(info->format);
1152
1153    /* list formats */
1154    list_formats(info, '[',
1155		 &next_format, &formats, &num_formats, &has_default, NULL, NULL);
1156
1157    /* ~:[false;true] */
1158    if (info->args.collon) {
1159	/* one argument always consumed */
1160	if (!CONSP(arguments))
1161	    parse_error(&(info->args), PARSE_NOARGSLEFT);
1162	object = CAR(arguments);
1163	arguments = CDR(arguments);
1164	--num_arguments;
1165	choice = object == NIL ? 0 : 1;
1166    }
1167    /* ~@[true] */
1168    else if (info->args.atsign) {
1169	/* argument consumed only if nil, but one must be available */
1170	if (!CONSP(arguments))
1171	    parse_error(&(info->args), PARSE_NOARGSLEFT);
1172	if (CAR(arguments) != NIL)
1173	    choice = 0;
1174	else {
1175	    object = CAR(arguments);
1176	    arguments = CDR(arguments);
1177	    --num_arguments;
1178	}
1179    }
1180    /* ~n[...~] */
1181    else if (info->args.arguments[0].specified)
1182	/* no arguments consumed */
1183	choice = info->args.arguments[0].value;
1184    /* ~[...~] */
1185    else {
1186	/* one argument consumed, it is the index in the available formats */
1187	if (!CONSP(arguments))
1188	    parse_error(&(info->args), PARSE_NOARGSLEFT);
1189	object = CAR(arguments);
1190	arguments = CDR(arguments);
1191	--num_arguments;
1192	/* no error if it isn't a number? */
1193	if (FIXNUMP(object))
1194	    choice = FIXNUM_VALUE(object);
1195    }
1196
1197    /* update anything that may have changed */
1198    *(info->object) = object;
1199    *(info->arguments) = arguments;
1200    *(info->num_arguments) = num_arguments;
1201
1202    /* if choice is out of range check if there is a default choice */
1203    if (has_default && (choice < 0 || choice >= num_formats))
1204	choice = num_formats - 1;
1205
1206    /* if one of the formats must be parsed */
1207    if (choice >= 0 && choice < num_formats) {
1208	FmtInfo conditional_info;
1209
1210	/* most information is the same */
1211	memcpy(&conditional_info, info, sizeof(FmtInfo));
1212
1213	/* set new format string */
1214	format = formats[choice];
1215	conditional_info.args.base = conditional_info.args.format = format;
1216	conditional_info.format = &format;
1217
1218	/* do the conditional format */
1219	LispFormat(stream, &conditional_info);
1220    }
1221
1222    /* free temporary memory */
1223    free_formats(formats, num_formats);
1224
1225    /* this information always updated */
1226    *(info->format) = next_format;
1227}
1228
1229static void
1230format_iterate(LispObj *stream, FmtInfo *info)
1231{
1232    FmtInfo iterate_info;
1233    LispObj *object, *arguments, *iarguments, *iobject;
1234    char *format, *next_format, *loop_format, **formats;
1235    int num_arguments, iterate, iterate_max, has_max, has_min, inum_arguments,
1236	num_formats;
1237
1238    /* save information that may change */
1239    object = *(info->object);
1240    arguments = *(info->arguments);
1241    num_arguments = *(info->num_arguments);
1242
1243    /* initialize */
1244    iterate = has_min = 0;
1245    next_format = *(info->format);
1246
1247    /* if has_max set, iterate at most iterate_max times */
1248    has_max = info->args.arguments[0].specified;
1249    iterate_max = info->args.arguments[0].value;
1250
1251    /* list formats */
1252    list_formats(info, '{', &next_format, &formats, &num_formats,
1253		 NULL, NULL, NULL);
1254    loop_format = formats[0];
1255
1256    /* most information is the same */
1257    memcpy(&iterate_info, info, sizeof(FmtInfo));
1258
1259    /* ~{...~} */
1260    if (!info->args.atsign && !info->args.collon) {
1261	/* next argument is the argument list for the iteration */
1262
1263	/* fetch argument list, must exist */
1264	if (!CONSP(arguments))
1265	    parse_error(&(info->args), PARSE_NOARGSLEFT);
1266	iarguments = object = CAR(arguments);
1267	object = CAR(arguments);
1268	arguments = CDR(arguments);
1269	--num_arguments;
1270
1271	inum_arguments = 0;
1272	if (CONSP(object)) {
1273	    /* count arguments to format */
1274	    for (iobject = object; CONSP(iobject); iobject = CDR(iobject))
1275		++inum_arguments;
1276	}
1277	else if (object != NIL)
1278	    generic_error(&(info->args), GENERIC_BADLIST);
1279
1280	iobject = NIL;
1281
1282	/* set new arguments to recursive calls */
1283	iarguments = object;
1284	iterate_info.base_arguments = iarguments;
1285	iterate_info.total_arguments = inum_arguments;
1286	iterate_info.object = &iobject;
1287	iterate_info.arguments = &iarguments;
1288	iterate_info.num_arguments = &inum_arguments;
1289
1290	/* iterate */
1291	for (;; iterate++) {
1292	    /* if maximum iterations done or all arguments consumed */
1293	    if (has_max && iterate > iterate_max)
1294		break;
1295	    else if (inum_arguments == 0 && (!has_min || iterate > 0))
1296		break;
1297
1298	    format = loop_format;
1299
1300	    /* set new format string */
1301	    iterate_info.args.base = iterate_info.args.format = format;
1302	    iterate_info.format = &format;
1303
1304	    /* information for possible ~^, in this case ~:^ is a noop */
1305	    iterate_info.iteration = ITERATION_NORMAL;
1306
1307	    /* do the format */
1308	    LispFormat(stream, &iterate_info);
1309
1310	    /* check for forced loop break */
1311	    if (iterate_info.upandout & UPANDOUT_HASH)
1312		break;
1313	}
1314    }
1315    /* ~:@{...~} */
1316    else if (info->args.atsign && info->args.collon) {
1317	/* every following argument is the argument list for the iteration */
1318
1319	/* iterate */
1320	for (;; iterate++) {
1321	    /* if maximum iterations done or all arguments consumed */
1322	    if (has_max && iterate > iterate_max)
1323		break;
1324	    else if (num_arguments == 0 && (!has_min || iterate > 0))
1325		break;
1326
1327	    /* fetch argument list, must exist */
1328	    if (!CONSP(arguments))
1329		parse_error(&(info->args), PARSE_NOARGSLEFT);
1330	    iarguments = object = CAR(arguments);
1331	    object = CAR(arguments);
1332	    arguments = CDR(arguments);
1333	    --num_arguments;
1334
1335	    inum_arguments = 0;
1336	    if (CONSP(object)) {
1337		/* count arguments to format */
1338		for (iobject = object; CONSP(iobject); iobject = CDR(iobject))
1339		    ++inum_arguments;
1340	    }
1341	    else if (object != NIL)
1342		generic_error(&(info->args), GENERIC_BADLIST);
1343
1344	    iobject = NIL;
1345
1346	    /* set new arguments to recursive calls */
1347	    iarguments = object;
1348	    iterate_info.base_arguments = iarguments;
1349	    iterate_info.total_arguments = inum_arguments;
1350	    iterate_info.object = &iobject;
1351	    iterate_info.arguments = &iarguments;
1352	    iterate_info.num_arguments = &inum_arguments;
1353
1354	    format = loop_format;
1355
1356	    /* set new format string */
1357	    iterate_info.args.base = iterate_info.args.format = format;
1358	    iterate_info.format = &format;
1359
1360	    /* information for possible ~^ */
1361	    iterate_info.iteration =
1362		num_arguments > 0 ? ITERATION_NORMAL : ITERATION_LAST;
1363
1364	    /* do the format */
1365	    LispFormat(stream, &iterate_info);
1366
1367	    /* check for forced loop break */
1368	    if (iterate_info.upandout & UPANDOUT_HASH)
1369		break;
1370	}
1371    }
1372    /* ~:{...~} */
1373    else if (info->args.collon) {
1374	/* next argument is a list of lists */
1375
1376	LispObj *sarguments, *sobject;
1377	int snum_arguments;
1378
1379	/* fetch argument list, must exist */
1380	if (!CONSP(arguments))
1381	    parse_error(&(info->args), PARSE_NOARGSLEFT);
1382	sarguments = object = CAR(arguments);
1383	object = CAR(arguments);
1384	arguments = CDR(arguments);
1385	--num_arguments;
1386
1387	snum_arguments = 0;
1388	if (CONSP(object)) {
1389	    /* count arguments to format */
1390	    for (sobject = object; CONSP(sobject); sobject = CDR(sobject))
1391		++snum_arguments;
1392	}
1393	else
1394	    generic_error(&(info->args), GENERIC_BADLIST);
1395
1396	/* iterate */
1397	for (;; iterate++) {
1398	    /* if maximum iterations done or all arguments consumed */
1399	    if (has_max && iterate > iterate_max)
1400		break;
1401	    else if (snum_arguments == 0 && (!has_min || iterate > 0))
1402		break;
1403
1404	    /* fetch argument list, must exist */
1405	    if (!CONSP(sarguments))
1406		parse_error(&(info->args), PARSE_NOARGSLEFT);
1407	    iarguments = sobject = CAR(sarguments);
1408	    sobject = CAR(sarguments);
1409	    sarguments = CDR(sarguments);
1410	    --snum_arguments;
1411
1412	    inum_arguments = 0;
1413	    if (CONSP(object)) {
1414		/* count arguments to format */
1415		for (iobject = sobject; CONSP(iobject); iobject = CDR(iobject))
1416		    ++inum_arguments;
1417	    }
1418	    else if (sobject != NIL)
1419		generic_error(&(info->args), GENERIC_BADLIST);
1420
1421	    iobject = NIL;
1422
1423	    /* set new arguments to recursive calls */
1424	    iarguments = sobject;
1425	    iterate_info.base_arguments = iarguments;
1426	    iterate_info.total_arguments = inum_arguments;
1427	    iterate_info.object = &iobject;
1428	    iterate_info.arguments = &iarguments;
1429	    iterate_info.num_arguments = &inum_arguments;
1430
1431	    format = loop_format;
1432
1433	    /* set new format string */
1434	    iterate_info.args.base = iterate_info.args.format = format;
1435	    iterate_info.format = &format;
1436
1437	    /* information for possible ~^ */
1438	    iterate_info.iteration =
1439		snum_arguments > 0 ? ITERATION_NORMAL : ITERATION_LAST;
1440
1441	    /* do the format */
1442	    LispFormat(stream, &iterate_info);
1443
1444	    /* check for forced loop break */
1445	    if (iterate_info.upandout & UPANDOUT_HASH)
1446		break;
1447	}
1448    }
1449    /* ~@{...~} */
1450    else if (info->args.atsign) {
1451	/* current argument list is used */
1452
1453	/* set new arguments to recursive calls */
1454	iterate_info.base_arguments = info->base_arguments;
1455	iterate_info.total_arguments = info->total_arguments;
1456	iterate_info.object = &object;
1457	iterate_info.arguments = &arguments;
1458	iterate_info.num_arguments = &num_arguments;
1459
1460	for (;; iterate++) {
1461	    /* if maximum iterations done or all arguments consumed */
1462	    if (has_max && iterate > iterate_max)
1463		break;
1464	    else if (num_arguments == 0 && (!has_min || iterate > 0))
1465		break;
1466
1467	    format = loop_format;
1468
1469	    /* set new format string */
1470	    iterate_info.args.base = iterate_info.args.format = format;
1471	    iterate_info.format = &format;
1472
1473	    /* information for possible ~^, in this case ~:^ is a noop */
1474	    iterate_info.iteration = ITERATION_NORMAL;
1475
1476	    /* do the format */
1477	    LispFormat(stream, &iterate_info);
1478
1479	    /* check for forced loop break */
1480	    if (iterate_info.upandout & UPANDOUT_HASH)
1481		break;
1482	}
1483    }
1484
1485    /* free temporary memory */
1486    free_formats(formats, num_formats);
1487
1488    /* update anything that may have changed */
1489    *(info->object) = object;
1490    *(info->arguments) = arguments;
1491    *(info->num_arguments) = num_arguments;
1492
1493    /* this information always updated */
1494    *(info->format) = next_format;
1495}
1496
1497static void
1498format_justify(LispObj *stream, FmtInfo *info)
1499{
1500    GC_ENTER();
1501    FmtInfo justify_info;
1502    char **formats, *format, *next_format;
1503    const char *str;
1504    LispObj *string, *strings = NIL, *cons;
1505    int atsign = info->args.atsign,
1506	collon = info->args.collon,
1507	mincol = info->args.arguments[0].value,
1508	colinc = info->args.arguments[1].value,
1509	minpad = info->args.arguments[2].value,
1510	padchar = info->args.arguments[3].value;
1511    int i, k, total_length, length, padding, num_formats, has_default,
1512	comma_width, line_width, size, extra;
1513
1514    next_format = *(info->format);
1515
1516    /* list formats */
1517    list_formats(info, '<', &next_format, &formats, &num_formats,
1518		 &has_default, &comma_width, &line_width);
1519
1520    /* initialize list of strings streams */
1521    if (num_formats) {
1522	string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
1523	strings = cons = CONS(string, NIL);
1524	GC_PROTECT(strings);
1525	for (i = 1; i < num_formats; i++) {
1526	    string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
1527	    RPLACD(cons, CONS(string, NIL));
1528	    cons = CDR(cons);
1529	}
1530    }
1531
1532    /* most information is the same */
1533    memcpy(&justify_info, info, sizeof(FmtInfo));
1534
1535    /* loop formating strings */
1536    for (i = 0, cons = strings; i < num_formats; i++, cons = CDR(cons)) {
1537	/* set new format string */
1538	format = formats[i];
1539	justify_info.args.base = justify_info.args.format = format;
1540	justify_info.format = &format;
1541
1542	/* format string, maybe consuming arguments */
1543	LispFormat(CAR(cons), &justify_info);
1544
1545	/* if format was aborted, it is discarded */
1546	if (justify_info.upandout)
1547	    RPLACA(cons, NIL);
1548	/* check if the entire "main" iteration must be aborted */
1549	if (justify_info.upandout & UPANDOUT_COLLON) {
1550	    for (cons = CDR(cons); i < num_formats; i++, cons = CDR(cons))
1551		RPLACA(cons, NIL);
1552	    break;
1553	}
1554    }
1555
1556    /* free temporary format strings */
1557    free_formats(formats, num_formats);
1558
1559    /* remove aborted formats */
1560	/* first remove leading discarded formats */
1561    if (CAR(strings) == NIL) {
1562	while (CAR(strings) == NIL) {
1563	    strings = CDR(strings);
1564	    --num_formats;
1565	}
1566	/* keep strings gc protected, discarding first entries */
1567	lisp__data.protect.objects[gc__protect] = strings;
1568    }
1569	/* now remove intermediary discarded formats */
1570    cons = strings;
1571    while (CONSP(cons)) {
1572	if (CONSP(CDR(cons)) && CAR(CDR(cons)) == NIL) {
1573	    RPLACD(cons, CDR(CDR(cons)));
1574	    --num_formats;
1575	}
1576	else
1577	    cons = CDR(cons);
1578    }
1579
1580    /* calculate total length required for output */
1581    if (has_default)
1582	cons = CDR(strings);	/* if has_defaults, strings is surely a list */
1583    else
1584	cons = strings;
1585    for (total_length = 0; CONSP(cons); cons = CDR(cons))
1586	total_length += SSTREAMP(CAR(cons))->length;
1587
1588    /* initialize pointer to string streams */
1589    if (has_default)
1590	cons = CDR(strings);
1591    else
1592	cons = strings;
1593
1594    /* check if padding will need to be printed */
1595    extra = 0;
1596    padding = mincol - total_length;
1597    if (padding < 0)
1598	k = padding = 0;
1599    else {
1600	int num_fields = num_formats - (has_default != 0);
1601
1602	if (num_fields > 1) {
1603	    /* check if padding is distributed in num_fields or
1604	     * num_fields - 1 steps */
1605	    if (!collon)
1606		--num_fields;
1607	}
1608
1609	if (num_fields)
1610	    k = padding / num_fields;
1611	else
1612	    k = padding;
1613
1614	if (k <= 0)
1615	    k = colinc;
1616	else if (colinc)
1617	    k = k + (k % colinc);
1618	extra = mincol - (num_fields * k + total_length);
1619	if (extra < 0)
1620	    extra = 0;
1621    }
1622    if (padding && k < minpad) {
1623	k = minpad;
1624	if (colinc)
1625	    k = k + (k % colinc);
1626    }
1627
1628    /* first check for the special case of only one string being justified */
1629    if (num_formats - has_default == 1) {
1630	if (has_default && line_width > 0 && comma_width >= 0 &&
1631	    total_length + comma_width > line_width) {
1632	    str = LispGetSstring(SSTREAMP(CAR(strings)), &size);
1633	    LispWriteStr(stream, str, size);
1634	}
1635	string = has_default ? CAR(CDR(strings)) : CAR(strings);
1636	/* check if need left padding */
1637	if (k && !atsign) {
1638	    LispWriteChars(stream, padchar, k);
1639	    k = 0;
1640	}
1641	/* check for centralizing text */
1642	else if (k && atsign && collon) {
1643	    LispWriteChars(stream, padchar, k / 2 + ((k / 2) & 1));
1644	    k -= k / 2;
1645	}
1646	str = LispGetSstring(SSTREAMP(string), &size);
1647	LispWriteStr(stream, str, size);
1648	/* if any padding remaining */
1649	if (k)
1650	    LispWriteChars(stream, padchar, k);
1651    }
1652    else {
1653	LispObj *result;
1654	int last, spaces_before, padout;
1655
1656	/* if has default, need to check output length */
1657	if (has_default && line_width > 0 && comma_width >= 0) {
1658	    result = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
1659	    GC_PROTECT(result);
1660	}
1661	/* else write directly to stream */
1662	else
1663	    result = stream;
1664
1665	/* loop printing justified text */
1666	    /* padout controls padding for cases where padding is
1667	     * is separated in n-1 chunks, where n is the number of
1668	     * formatted strings.
1669	     */
1670	for (i = padout = 0; CONSP(cons); i++, cons = CDR(cons), --extra) {
1671	    string = CAR(cons);
1672	    last = !CONSP(CDR(cons));
1673
1674	    spaces_before = (i != 0 || collon) && (!last || !atsign);
1675
1676	    if (!spaces_before) {
1677		/* check for special case */
1678		if (last && atsign && collon && padding > 0) {
1679		    int spaces;
1680
1681		    spaces = minpad > colinc ? minpad : colinc;
1682		    LispWriteChars(result, padchar, spaces + (extra > 0));
1683		    k -= spaces;
1684		}
1685		str = LispGetSstring(SSTREAMP(string), &size);
1686		LispWriteStr(result, str, size);
1687		padout = 0;
1688	    }
1689	    if (!padout)
1690		LispWriteChars(result, padchar, k + (extra > 0));
1691	    padout = k;
1692	    /* if not first string, or if left padding specified */
1693	    if (spaces_before) {
1694		str = LispGetSstring(SSTREAMP(string), &size);
1695		LispWriteStr(result, str, size);
1696		padout = 0;
1697	    }
1698	    padding -= k;
1699	}
1700
1701	if (has_default && line_width > 0 && comma_width >= 0) {
1702	    length = SSTREAMP(result)->length + LispGetColumn(stream);
1703
1704	    /* if current line is too large */
1705	    if (has_default && length + comma_width > line_width) {
1706		str = LispGetSstring(SSTREAMP(CAR(strings)), &size);
1707		LispWriteStr(stream, str, size);
1708	    }
1709
1710	    /* write result to stream */
1711	    str = LispGetSstring(SSTREAMP(result), &size);
1712	    LispWriteStr(stream, str, size);
1713	}
1714    }
1715
1716    /* unprotect string streams from GC */
1717    GC_LEAVE();
1718
1719    /* this information always updated */
1720    *(info->format) = next_format;
1721}
1722
1723static void
1724LispFormat(LispObj *stream, FmtInfo *info)
1725{
1726    FmtArgs *args;
1727    const FmtDefs *defs = NULL;
1728    LispObj *object, *arguments;
1729    char stk[256], *format, *next_format;
1730    int length, num_arguments, code, need_update, need_argument, hash, head;
1731
1732    /* arguments that will be updated on function exit */
1733    format = *(info->format);
1734    object = *(info->object);
1735    arguments = *(info->arguments);
1736    num_arguments = *(info->num_arguments);
1737
1738    /* initialize */
1739    length = 0;
1740    args = &(info->args);
1741    info->upandout = 0;
1742
1743    while (*format) {
1744	if (*format == '~') {
1745	    /* flush non formatted characters */
1746	    if (length) {
1747		LispWriteStr(stream, stk, length);
1748		length = 0;
1749	    }
1750
1751	    need_argument = need_update = hash = 0;
1752
1753	    /* parse parameters */
1754	    args->format = format + 1;
1755	    next_format = parse_arguments(format + 1, args, &num_arguments,
1756					  &arguments, &code);
1757	    if (code != NOERROR)
1758		parse_error(args, code);
1759
1760	    /* check parameters */
1761	    switch (args->command) {
1762		case 'A': case 'S':
1763		    defs = &AsciiDefs;
1764		    break;
1765		case 'B': case 'O': case 'D': case 'X':
1766		    defs = &IntegerDefs;
1767		    break;
1768		case 'R':
1769		    defs = &RadixDefs;
1770		    break;
1771		case 'P': case 'C':
1772		    defs = &NoneDefs;
1773		    break;
1774		case 'F':
1775		    defs = &FixedFloatDefs;
1776		    break;
1777		case 'E': case 'G':
1778		    defs = &ExponentialFloatDefs;
1779		    break;
1780		case '$':
1781		    defs = &DollarFloatDefs;
1782		    break;
1783		case '%': case '&': case '|': case '~': case '\n':
1784		    defs = &OneDefs;
1785		    break;
1786		case 'T':
1787		    defs = &TabulateDefs;
1788		    break;
1789		case '*':
1790		    defs = &OneDefs;
1791		    break;
1792		case '?': case '(':
1793		    defs = &NoneDefs;
1794		    break;
1795		case ')':
1796		    /* this is never seen, processed in format_case_conversion */
1797		    format_error(args, "no match for directive ~)");
1798		case '[':
1799		    defs = &OneDefs;
1800		    break;
1801		case ']':
1802		    /* this is never seen, processed in format_conditional */
1803		    format_error(args, "no match for directive ~]");
1804		case '{':
1805		    defs = &OneDefs;
1806		    break;
1807		case '}':
1808		    /* this is never seen, processed in format_iterate */
1809		    format_error(args, "no match for directive ~}");
1810		case '<':
1811		    defs = &AsciiDefs;
1812		    break;
1813		case '>':
1814		    /* this is never seen, processed in format_justify */
1815		    format_error(args, "no match for directive ~>");
1816		case ';':
1817		    /* this is never seen here */
1818		    format_error(args, "misplaced directive ~;");
1819		case '#':
1820		    /* special handling for ~#^ */
1821		    if (*next_format == '^') {
1822			++next_format;
1823			hash = 1;
1824			defs = &NoneDefs;
1825			args->command = '^';
1826			break;
1827		    }
1828		    parse_error(args, PARSE_BADDIRECTIVE);
1829		case '^':
1830		    defs = &NoneDefs;
1831		    break;
1832		default:
1833		    parse_error(args, PARSE_BADDIRECTIVE);
1834		    break;
1835	    }
1836	    merge_arguments(args, defs, &code);
1837	    if (code != NOERROR)
1838		merge_error(args, code);
1839
1840	    /* check if an argument is required by directive */
1841	    switch (args->command) {
1842		case 'A': case 'S':
1843		case 'B': case 'O': case 'D': case 'X': case 'R':
1844		    need_argument = 1;
1845		    break;
1846		case 'P':
1847		    /* if collon specified, plural is the last print argument */
1848		    need_argument = !args->collon;
1849		    break;
1850		case 'C':
1851		    need_argument = 1;
1852		    break;
1853		case 'F': case 'E': case 'G': case '$':
1854		    need_argument = 1;
1855		    break;
1856		case '%': case '&': case '|': case '~': case '\n':
1857		    break;
1858		case 'T':
1859		    break;
1860		case '*':			/* check arguments below */
1861		    need_update = 1;
1862		    break;
1863		case '?':
1864		    need_argument = need_update = 1;
1865		    break;
1866		case '(': case '[': case '{': case '<':
1867		    need_update = 1;
1868		    break;
1869		case '^':
1870		    break;
1871	    }
1872	    if (need_argument) {
1873		if (!CONSP(arguments))
1874		    parse_error(args, PARSE_NOARGSLEFT);
1875		object = CAR(arguments);
1876		arguments = CDR(arguments);
1877		--num_arguments;
1878	    }
1879
1880	    /* will do recursive calls that change info */
1881	    if (need_update) {
1882		*(info->format) = next_format;
1883		*(info->object) = object;
1884		*(info->arguments) = arguments;
1885		*(info->num_arguments) = num_arguments;
1886	    }
1887
1888	    /* everything seens fine, print the format directive */
1889	    switch (args->command) {
1890		case 'A':
1891		    head = lisp__data.env.length;
1892		    LispAddVar(Oprint_escape, NIL);
1893		    ++lisp__data.env.head;
1894		    format_ascii(stream, object, args);
1895		    lisp__data.env.head = lisp__data.env.length = head;
1896		    break;
1897		case 'S':
1898		    head = lisp__data.env.length;
1899		    LispAddVar(Oprint_escape, T);
1900		    ++lisp__data.env.head;
1901		    format_ascii(stream, object, args);
1902		    lisp__data.env.head = lisp__data.env.length = head;
1903		    break;
1904		case 'B':
1905		    format_in_radix(stream, object, 2, args);
1906		    break;
1907		case 'O':
1908		    format_in_radix(stream, object, 8, args);
1909		    break;
1910		case 'D':
1911		    format_in_radix(stream, object, 10, args);
1912		    break;
1913		case 'X':
1914		    format_in_radix(stream, object, 16, args);
1915		    break;
1916		case 'R':
1917		    /* if a single argument specified */
1918		    if (args->count)
1919			format_in_radix(stream, object, 0, args);
1920		    else
1921			format_radix_special(stream, object, args);
1922		    break;
1923		case 'P':
1924		    if (args->atsign) {
1925			if (FIXNUMP(object) && FIXNUM_VALUE(object) == 1)
1926			    LispWriteChar(stream, 'y');
1927			else
1928			    LispWriteStr(stream, "ies", 3);
1929		    }
1930		    else if (!FIXNUMP(object) || FIXNUM_VALUE(object) != 1)
1931			LispWriteChar(stream, 's');
1932		    break;
1933		case 'C':
1934		    format_character(stream, object, args);
1935		    break;
1936		case 'F':
1937		    format_fixed_float(stream, object, args);
1938		    break;
1939		case 'E':
1940		    format_exponential_float(stream, object, args);
1941		    break;
1942		case 'G':
1943		    format_general_float(stream, object, args);
1944		    break;
1945		case '$':
1946		    format_dollar_float(stream, object, args);
1947		    break;
1948		case '&':
1949		    if (LispGetColumn(stream) == 0)
1950			--args->arguments[0].value;
1951		case '%':
1952		    LispWriteChars(stream, '\n', args->arguments[0].value);
1953		    break;
1954		case '|':
1955		    LispWriteChars(stream, '\f', args->arguments[0].value);
1956		    break;
1957		case '~':
1958		    LispWriteChars(stream, '~', args->arguments[0].value);
1959		    break;
1960		case '\n':
1961		    if (!args->collon) {
1962			if (args->atsign)
1963			    LispWriteChar(stream, '\n');
1964			/* ignore newline and following spaces */
1965			while (*next_format && isspace(*next_format))
1966			    ++next_format;
1967		    }
1968		    break;
1969		case 'T':
1970		    format_tabulate(stream, args);
1971		    break;
1972		case '*':
1973		    format_goto(info);
1974		    break;
1975		case '?':
1976		    format_indirection(stream, object, info);
1977		    need_update = 1;
1978		    break;
1979		case '(':
1980		    format_case_conversion(stream, info);
1981		    /* next_format if far from what is set now */
1982		    next_format = *(info->format);
1983		    break;
1984		case '[':
1985		    format_conditional(stream, info);
1986		    /* next_format if far from what is set now */
1987		    next_format = *(info->format);
1988		    break;
1989		case '{':
1990		    format_iterate(stream, info);
1991		    /* next_format if far from what is set now */
1992		    next_format = *(info->format);
1993		    break;
1994		case '<':
1995		    format_justify(stream, info);
1996		    /* next_format if far from what is set now */
1997		    next_format = *(info->format);
1998		    break;
1999		case '^':
2000		    if (args->collon) {
2001			if (hash && num_arguments == 0) {
2002			    info->upandout = UPANDOUT_HASH;
2003			    goto format_up_and_out;
2004			}
2005			if (info->iteration &&
2006			    info->iteration == ITERATION_NORMAL)
2007			/* not exactly an error, but in this case,
2008			 * command is ignored */
2009			    break;
2010			info->upandout = UPANDOUT_COLLON;
2011			goto format_up_and_out;
2012		    }
2013		    else if (num_arguments == 0) {
2014			info->upandout = UPANDOUT_NORMAL;
2015			goto format_up_and_out;
2016		    }
2017		    break;
2018	    }
2019
2020	    if (need_update) {
2021		object = *(info->object);
2022		arguments = *(info->arguments);
2023		num_arguments = *(info->num_arguments);
2024	    }
2025
2026	    format = next_format;
2027	}
2028	else {
2029	    if (length >= sizeof(stk)) {
2030		LispWriteStr(stream, stk, length);
2031		length = 0;
2032	    }
2033	    stk[length++] = *format++;
2034	}
2035    }
2036
2037    /* flush any peding output */
2038    if (length)
2039	LispWriteStr(stream, stk, length);
2040
2041format_up_and_out:
2042    /* update for recursive call */
2043    *(info->format) = format;
2044    *(info->object) = object;
2045    *(info->arguments) = arguments;
2046    *(info->num_arguments) = num_arguments;
2047}
2048
2049LispObj *
2050Lisp_Format(LispBuiltin *builtin)
2051/*
2052 format destination control-string &rest arguments
2053 */
2054{
2055    GC_ENTER();
2056    FmtInfo info;
2057    LispObj *object;
2058    char *control_string;
2059    int num_arguments;
2060
2061    LispObj *stream, *format, *arguments;
2062
2063    arguments = ARGUMENT(2);
2064    format = ARGUMENT(1);
2065    stream = ARGUMENT(0);
2066
2067    /* check format and stream */
2068    CHECK_STRING(format);
2069    if (stream == NIL) {	/* return a string */
2070	stream = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
2071	GC_PROTECT(stream);
2072    }
2073    else if (stream == T ||	/* print directly to *standard-output* */
2074	     stream == STANDARD_OUTPUT)
2075	stream = NIL;
2076    else {
2077	CHECK_STREAM(stream);
2078	if (!stream->data.stream.writable)
2079	    LispDestroy("%s: stream %s is not writable",
2080			STRFUN(builtin), STROBJ(stream));
2081    }
2082
2083    /* count number of arguments */
2084    for (object = arguments, num_arguments = 0; CONSP(object);
2085	 object = CDR(object), num_arguments++)
2086	;
2087
2088    /* initialize plural/argument info */
2089    object = NIL;
2090
2091    /* the format string */
2092    control_string = THESTR(format);
2093
2094    /* arguments to recursive calls */
2095    info.args.base = control_string;
2096    info.base_arguments = arguments;
2097    info.total_arguments = num_arguments;
2098    info.format = &control_string;
2099    info.object = &object;
2100    info.arguments = &arguments;
2101    info.num_arguments = &num_arguments;
2102    info.iteration = 0;
2103
2104    /* format arguments */
2105    LispFormat(stream, &info);
2106
2107    /* if printing to stdout */
2108    if (stream == NIL)
2109	LispFflush(Stdout);
2110    /* else if printing to string-stream, return a string */
2111    else if (stream->data.stream.type == LispStreamString) {
2112	int length;
2113	const char *string;
2114
2115	string = LispGetSstring(SSTREAMP(stream), &length);
2116	stream = LSTRING(string, length);
2117    }
2118
2119    GC_LEAVE();
2120
2121    return (stream);
2122}
2123