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/write.c,v 1.31tsi Exp $ */
31
32#include "lisp/write.h"
33#include "lisp/hash.h"
34#include <math.h>
35#include <ctype.h>
36
37#define	FLOAT_PREC	17
38
39#define UPCASE		0
40#define DOWNCASE	1
41#define CAPITALIZE	2
42
43#define INCDEPTH()							\
44    if (++info->depth > MAX_STACK_DEPTH / 2)				\
45	LispDestroy("stack overflow")
46#define DECDEPTH()	--info->depth
47
48/*
49 * Types
50 */
51typedef struct _circle_info {
52    long circle_nth;		/* nth circular list */
53    LispObj *object;		/* the circular object */
54} circle_info;
55
56typedef struct _write_info {
57    long depth;
58    long level;			/* current level */
59    long length;		/* current length */
60    long print_level;		/* *print-level* when started printing */
61    long print_length;		/* *print-length* when started printing */
62
63    int print_escape;
64    int print_case;
65
66    long circle_count;
67    /* used while building circle info */
68    LispObj **objects;
69    long num_objects;
70    /* the circular lists */
71    circle_info *circles;
72    long num_circles;
73} write_info;
74
75/*
76 * Prototypes
77 */
78static void check_stream(LispObj*, LispFile**, LispString**, int);
79static void parse_double(char*, int*, double, int);
80static int float_string_inc(char*, int);
81static void format_integer(char*, long, int);
82static int LispWriteCPointer(LispObj*, void*);
83static int LispWriteCString(LispObj*, char*, long, write_info*);
84static int LispDoFormatExponentialFloat(LispObj*, LispObj*,
85					int, int, int*, int, int,
86					int, int, int, int);
87
88static int LispWriteInteger(LispObj*, LispObj*);
89static int LispWriteCharacter(LispObj*, LispObj*, write_info*);
90static int LispWriteString(LispObj*, LispObj*, write_info*);
91static int LispWriteFloat(LispObj*, LispObj*);
92static int LispWriteAtom(LispObj*, LispObj*, write_info*);
93static int LispDoWriteAtom(LispObj*, const char*, int, int);
94static int LispWriteList(LispObj*, LispObj*, write_info*, int);
95static int LispWriteArray(LispObj*, LispObj*, write_info*);
96static int LispWriteStruct(LispObj*, LispObj*, write_info*);
97static int LispDoWriteObject(LispObj*, LispObj*, write_info*, int);
98static void LispBuildCircle(LispObj*, write_info*);
99static void LispDoBuildCircle(LispObj*, write_info*);
100static long LispCheckCircle(LispObj*, write_info*);
101static int LispPrintCircle(LispObj*, LispObj*, long, int*, write_info*);
102static int LispWriteAlist(LispObj*, LispArgList*, write_info*);
103
104/*
105 * Initialization
106 */
107LispObj *Oprint_level, *Oprint_length, *Oprint_circle,
108	*Oprint_escape, *Oprint_case;
109LispObj *Kupcase, *Kdowncase, *Kcapitalize;
110
111/*
112 * Implementation
113 */
114void
115LispWriteInit(void)
116{
117    Oprint_level	= STATIC_ATOM("*PRINT-LEVEL*");
118    LispProclaimSpecial(Oprint_level, NIL, NIL);
119    LispExportSymbol(Oprint_level);
120
121    Oprint_length	= STATIC_ATOM("*PRINT-LENGTH*");
122    LispProclaimSpecial(Oprint_length, NIL, NIL);
123    LispExportSymbol(Oprint_length);
124
125    Oprint_circle	= STATIC_ATOM("*PRINT-CIRCLE*");
126    LispProclaimSpecial(Oprint_circle, T, NIL);
127    LispExportSymbol(Oprint_circle);
128
129    Oprint_escape	= STATIC_ATOM("*PRINT-ESCAPE*");
130    LispProclaimSpecial(Oprint_escape, T, NIL);
131    LispExportSymbol(Oprint_escape);
132
133    Kupcase		= KEYWORD("UPCASE");
134    Kdowncase		= KEYWORD("DOWNCASE");
135    Kcapitalize		= KEYWORD("CAPITALIZE");
136    Oprint_case		= STATIC_ATOM("*PRINT-CASE*");
137    LispProclaimSpecial(Oprint_case, Kupcase, NIL);
138    LispExportSymbol(Oprint_case);
139}
140
141LispObj *
142Lisp_FreshLine(LispBuiltin *builtin)
143/*
144 fresh-line &optional output-stream
145 */
146{
147    LispObj *output_stream;
148
149    output_stream = ARGUMENT(0);
150
151    if (output_stream == UNSPEC)
152	output_stream = NIL;
153    else if (output_stream != NIL) {
154	CHECK_STREAM(output_stream);
155    }
156    if (LispGetColumn(output_stream)) {
157	LispWriteChar(output_stream, '\n');
158	if (output_stream == NIL ||
159	    (output_stream->data.stream.type == LispStreamStandard &&
160	     output_stream->data.stream.source.file == Stdout))
161	    LispFflush(Stdout);
162	return (T);
163    }
164
165    return (NIL);
166}
167
168LispObj *
169Lisp_Prin1(LispBuiltin *builtin)
170/*
171 prin1 object &optional output-stream
172 */
173{
174    LispObj *object, *output_stream;
175
176    output_stream = ARGUMENT(1);
177    object = ARGUMENT(0);
178
179    if (output_stream == UNSPEC)
180	output_stream = NIL;
181    LispPrint(object, output_stream, 0);
182
183    return (object);
184}
185
186LispObj *
187Lisp_Princ(LispBuiltin *builtin)
188/*
189 princ object &optional output-stream
190 */
191{
192    int head;
193    LispObj *object, *output_stream;
194
195    output_stream = ARGUMENT(1);
196    object = ARGUMENT(0);
197
198    if (output_stream == UNSPEC)
199	output_stream = NIL;
200    head = lisp__data.env.length;
201    LispAddVar(Oprint_escape, NIL);
202    ++lisp__data.env.head;
203    LispPrint(object, output_stream, 0);
204    lisp__data.env.head = lisp__data.env.length = head;
205
206    return (object);
207}
208
209LispObj *
210Lisp_Print(LispBuiltin *builtin)
211/*
212 print object &optional output-stream
213 */
214{
215    LispObj *object, *output_stream;
216
217    output_stream = ARGUMENT(1);
218    object = ARGUMENT(0);
219
220    if (output_stream == UNSPEC)
221	output_stream = NIL;
222    LispWriteChar(output_stream, '\n');
223    LispPrint(object, output_stream, 0);
224    LispWriteChar(output_stream, ' ');
225
226    return (object);
227}
228
229LispObj *
230Lisp_Terpri(LispBuiltin *builtin)
231/*
232 terpri &optional output-stream
233 */
234{
235    LispObj *output_stream;
236
237    output_stream = ARGUMENT(0);
238
239    if (output_stream == UNSPEC)
240	output_stream = NIL;
241    else if (output_stream != NIL) {
242	CHECK_STREAM(output_stream);
243    }
244    LispWriteChar(output_stream, '\n');
245    if (output_stream == NIL ||
246	(output_stream->data.stream.type == LispStreamStandard &&
247	 output_stream->data.stream.source.file == Stdout))
248	LispFflush(Stdout);
249
250    return (NIL);
251}
252
253LispObj *
254Lisp_Write(LispBuiltin *builtin)
255/*
256 write object &key case circle escape length level lines pretty readably right-margin stream
257 */
258{
259    int head = lisp__data.env.length;
260
261    LispObj *object, *ocase, *circle, *escape, *length, *level, *stream;
262
263    stream = ARGUMENT(10);
264    level = ARGUMENT(5);
265    length = ARGUMENT(4);
266    escape = ARGUMENT(3);
267    circle = ARGUMENT(2);
268    ocase = ARGUMENT(1);
269    object = ARGUMENT(0);
270
271    if (stream == UNSPEC)
272	stream = NIL;
273    else if (stream != NIL) {
274	CHECK_STREAM(stream);
275    }
276
277    /* prepare the printer environment */
278    if (circle != UNSPEC)
279	LispAddVar(Oprint_circle, circle);
280    if (length != UNSPEC)
281	LispAddVar(Oprint_length, length);
282    if (level != UNSPEC)
283	LispAddVar(Oprint_level, level);
284    if (ocase != UNSPEC)
285	LispAddVar(Oprint_case, ocase);
286    if (escape != UNSPEC)
287	LispAddVar(Oprint_escape, escape);
288
289    lisp__data.env.head = lisp__data.env.length;
290
291    (void)LispWriteObject(stream, object);
292
293    lisp__data.env.head = lisp__data.env.length = head;
294
295    return (object);
296}
297
298LispObj *
299Lisp_WriteChar(LispBuiltin *builtin)
300/*
301 write-char character &optional output-stream
302 */
303{
304    int ch;
305
306    LispObj *character, *output_stream;
307
308    output_stream = ARGUMENT(1);
309    character = ARGUMENT(0);
310
311    if (output_stream == UNSPEC)
312	output_stream = NIL;
313    CHECK_SCHAR(character);
314    ch = SCHAR_VALUE(character);
315
316    LispWriteChar(output_stream, ch);
317
318    return (character);
319}
320
321LispObj *
322Lisp_WriteLine(LispBuiltin *builtin)
323/*
324 write-line string &optional output-stream &key start end
325 */
326{
327    return (LispWriteString_(builtin, 1));
328}
329
330LispObj *
331Lisp_WriteString(LispBuiltin *builtin)
332/*
333 write-string string &optional output-stream &key start end
334 */
335{
336    return (LispWriteString_(builtin, 0));
337}
338
339
340int
341LispWriteObject(LispObj *stream, LispObj *object)
342{
343    write_info info;
344    int bytes;
345    LispObj *level, *length, *circle, *oescape, *ocase;
346
347    /* current state */
348    info.depth = info.level = info.length = 0;
349
350    /* maximum level to descend */
351    level = LispGetVar(Oprint_level);
352    if (level && INDEXP(level))
353	info.print_level = FIXNUM_VALUE(level);
354    else
355	info.print_level = -1;
356
357    /* maximum list length */
358    length = LispGetVar(Oprint_length);
359    if (length && INDEXP(length))
360	info.print_length = FIXNUM_VALUE(length);
361    else
362	info.print_length = -1;
363
364    /* detect circular/shared objects? */
365    circle = LispGetVar(Oprint_circle);
366    info.circle_count = 0;
367    info.objects = NULL;
368    info.num_objects = 0;
369    info.circles = NULL;
370    info.num_circles = 0;
371    if (circle && circle != NIL) {
372	LispBuildCircle(object, &info);
373	/* free this data now */
374	if (info.num_objects) {
375	    LispFree(info.objects);
376	    info.num_objects = 0;
377	}
378    }
379
380    /* escape characters and strings? */
381    oescape = LispGetVar(Oprint_escape);
382    if (oescape != NULL)
383	info.print_escape = oescape == NIL;
384    else
385	info.print_escape = -1;
386
387    /* don't use the default case printing? */
388    ocase = LispGetVar(Oprint_case);
389    if (ocase == Kdowncase)
390	info.print_case = DOWNCASE;
391    else if (ocase == Kcapitalize)
392	info.print_case = CAPITALIZE;
393    else
394	info.print_case = UPCASE;
395
396    bytes = LispDoWriteObject(stream, object, &info, 1);
397    if (circle && circle != NIL && info.num_circles)
398	LispFree(info.circles);
399
400    return (bytes);
401}
402
403static void
404LispBuildCircle(LispObj *object, write_info *info)
405{
406    LispObj *list;
407
408    switch (OBJECT_TYPE(object)) {
409	case LispCons_t:
410	    LispDoBuildCircle(object, info);
411	    break;
412	case LispArray_t:
413	    /* Currently arrays are implemented as lists, but only
414	     * the elements could/should be circular */
415	    if (LispCheckCircle(object, info) >= 0)
416		return;
417	    LispDoBuildCircle(object, info);
418	    for (list = object->data.array.list;
419		 CONSP(list); list = CDR(list))
420		LispBuildCircle(CAR(list), info);
421	    break;
422	case LispStruct_t:
423	    /* Like arrays, structs are currently implemented as lists,
424	     * but only the elements could/should be circular */
425	    if (LispCheckCircle(object, info) >= 0)
426		return;
427	    LispDoBuildCircle(object, info);
428	    for (list = object->data.struc.fields;
429		 CONSP(list); list = CDR(list))
430		LispBuildCircle(CAR(list), info);
431	    break;
432	case LispQuote_t:
433	case LispBackquote_t:
434	case LispFunctionQuote_t:
435	    LispDoBuildCircle(object, info);
436	    LispBuildCircle(object->data.quote, info);
437	    break;
438	case LispComma_t:
439	    LispDoBuildCircle(object, info);
440	    LispBuildCircle(object->data.comma.eval, info);
441	    break;
442	case LispLambda_t:
443	    /* Circularity in a function body should fail elsewhere... */
444	    if (LispCheckCircle(object, info) >= 0)
445		return;
446	    LispDoBuildCircle(object, info);
447	    LispBuildCircle(object->data.lambda.code, info);
448	    break;
449	default:
450	    break;
451    }
452}
453
454static void
455LispDoBuildCircle(LispObj *object, write_info *info)
456{
457    long i;
458
459    if (LispCheckCircle(object, info) >= 0)
460	return;
461
462    for (i = 0; i < info->num_objects; i++)
463	if (info->objects[i] == object) {
464	    /* circularity found */
465	    info->circles = LispRealloc(info->circles, sizeof(circle_info) *
466					(info->num_circles + 1));
467	    info->circles[info->num_circles].circle_nth = 0;
468	    info->circles[info->num_circles].object = object;
469	    ++info->num_circles;
470	    return;
471	}
472
473    /* object pointer not yet recorded */
474    if ((i % 16) == 0)
475	info->objects = LispRealloc(info->objects, sizeof(LispObj*) *
476				    (info->num_objects + 16));
477    info->objects[info->num_objects++] = object;
478
479    if (CONSP(object)) {
480	if (CONSP(CAR(object)))
481	    LispDoBuildCircle(CAR(object), info);
482	else
483	    LispBuildCircle(CAR(object), info);
484	if (CONSP(CDR(object)))
485	    LispDoBuildCircle(CDR(object), info);
486	else
487	    LispBuildCircle(CDR(object), info);
488    }
489}
490
491static long
492LispCheckCircle(LispObj *object, write_info *info)
493{
494    long i;
495
496    for (i = 0; i < info->num_circles; i++)
497	if (info->circles[i].object == object)
498	    return (i);
499
500    return (-1);
501}
502
503static int
504LispPrintCircle(LispObj *stream, LispObj *object, long circle,
505		int *length, write_info *info)
506{
507    char stk[32];
508
509    if (!info->circles[circle].circle_nth) {
510	sprintf(stk, "#%ld=", ++info->circle_count);
511	*length += LispWriteStr(stream, stk, strlen(stk));
512	info->circles[circle].circle_nth = info->circle_count;
513
514	return (1);
515    }
516    sprintf(stk, "#%ld#", info->circles[circle].circle_nth);
517    *length += LispWriteStr(stream, stk, strlen(stk));
518
519    return (0);
520}
521
522static int
523LispWriteAlist(LispObj *stream, LispArgList *alist, write_info *info)
524{
525    Atom_id name;
526    int i, length = 0, need_space = 0;
527
528#define WRITE_ATOM(object)						\
529    name = ATOMID(object);						\
530    length += LispDoWriteAtom(stream, name->value, name->length,	\
531			      info->print_case)
532#define WRITE_ATOMID(atomid)						\
533    length += LispDoWriteAtom(stream, atomid->value, atomid->length,	\
534			      info->print_case)
535#define WRITE_OBJECT(object)						\
536    length += LispDoWriteObject(stream, object, info, 1)
537#define WRITE_OPAREN()							\
538    length += LispWriteChar(stream, '(')
539#define WRITE_SPACE()							\
540    length += LispWriteChar(stream, ' ')
541#define WRITE_CPAREN()							\
542    length += LispWriteChar(stream, ')')
543
544    WRITE_OPAREN();
545    for (i = 0; i < alist->normals.num_symbols; i++) {
546	WRITE_ATOM(alist->normals.symbols[i]);
547	if (i + 1 < alist->normals.num_symbols)
548	    WRITE_SPACE();
549	else
550	    need_space = 1;
551    }
552    if (alist->optionals.num_symbols) {
553	if (need_space)
554	    WRITE_SPACE();
555	WRITE_ATOMID(Soptional);
556	WRITE_SPACE();
557	for (i = 0; i < alist->optionals.num_symbols; i++) {
558	    WRITE_OPAREN();
559	    WRITE_ATOM(alist->optionals.symbols[i]);
560	    WRITE_SPACE();
561	    WRITE_OBJECT(alist->optionals.defaults[i]);
562	    if (alist->optionals.sforms[i]) {
563		WRITE_SPACE();
564		WRITE_ATOM(alist->optionals.sforms[i]);
565	    }
566	    WRITE_CPAREN();
567	    if (i + 1 < alist->optionals.num_symbols)
568		WRITE_SPACE();
569	}
570	need_space = 1;
571    }
572    if (alist->keys.num_symbols) {
573	if (need_space)
574	    WRITE_SPACE();
575	length += LispDoWriteAtom(stream, Skey->value, 4, info->print_case);
576	WRITE_SPACE();
577	for (i = 0; i < alist->keys.num_symbols; i++) {
578	    WRITE_OPAREN();
579	    if (alist->keys.keys[i]) {
580		WRITE_OPAREN();
581		WRITE_ATOM(alist->keys.keys[i]);
582		WRITE_SPACE();
583	    }
584	    WRITE_ATOM(alist->keys.symbols[i]);
585	    if (alist->keys.keys[i])
586		WRITE_CPAREN();
587	    WRITE_SPACE();
588	    WRITE_OBJECT(alist->keys.defaults[i]);
589	    if (alist->keys.sforms[i]) {
590		WRITE_SPACE();
591		WRITE_ATOM(alist->keys.sforms[i]);
592	    }
593	    WRITE_CPAREN();
594	    if (i + 1 < alist->keys.num_symbols)
595		WRITE_SPACE();
596	}
597	need_space = 1;
598    }
599    if (alist->rest) {
600	if (need_space)
601	    WRITE_SPACE();
602	WRITE_ATOMID(Srest);
603	WRITE_SPACE();
604	WRITE_ATOM(alist->rest);
605	need_space = 1;
606    }
607    if (alist->auxs.num_symbols) {
608	if (need_space)
609	    WRITE_SPACE();
610	WRITE_ATOMID(Saux);
611	WRITE_SPACE();
612	for (i = 0; i < alist->auxs.num_symbols; i++) {
613	    WRITE_OPAREN();
614	    WRITE_ATOM(alist->auxs.symbols[i]);
615	    WRITE_SPACE();
616	    WRITE_OBJECT(alist->auxs.initials[i]);
617	    WRITE_CPAREN();
618	    if (i + 1 < alist->auxs.num_symbols)
619		WRITE_SPACE();
620	}
621    }
622    WRITE_CPAREN();
623
624#undef WRITE_ATOM
625#undef WRITE_ATOMID
626#undef WRITE_OBJECT
627#undef WRITE_OPAREN
628#undef WRITE_SPACE
629#undef WRITE_CPAREN
630
631    return (length);
632}
633
634static void
635check_stream(LispObj *stream,
636	     LispFile **file, LispString **string, int check_writable)
637{
638    /* NIL is UNIX stdout, *STANDARD-OUTPUT* may not be UNIX stdout */
639    if (stream == NIL) {
640	*file = Stdout;
641	*string = NULL;
642    }
643    else {
644	if (!STREAMP(stream))
645	    LispDestroy("%s is not a stream", STROBJ(stream));
646	if (check_writable && !stream->data.stream.writable)
647	    LispDestroy("%s is not writable", STROBJ(stream));
648	else if (stream->data.stream.type == LispStreamString) {
649	    *string = SSTREAMP(stream);
650	    *file = NULL;
651	}
652	else {
653	    if (stream->data.stream.type == LispStreamPipe)
654		*file = OPSTREAMP(stream);
655	    else
656		*file = stream->data.stream.source.file;
657	    *string = NULL;
658	}
659    }
660}
661
662/* Assumes buffer has enough storage, 64 bytes should be more than enough */
663static void
664parse_double(char *buffer, int *exponent, double value, int d)
665{
666    char stk[64], fmt[32], *ptr, *fract = NULL;
667    int positive = value >= 0.0;
668
669parse_double_again:
670    if (d >= 8) {
671	double dcheck;
672	int icheck, count;
673
674	/* this should to do the correct rounding */
675	for (count = 2;  count >= 0; count--) {
676	    icheck = d <= 0 ? 0 : d > FLOAT_PREC ? FLOAT_PREC - count : d - count;
677	    sprintf(fmt, "%%.%de", icheck);
678	    sprintf(stk, fmt, value);
679	    if (count) {
680		/* if the value read back is the same formatted */
681		sscanf(stk, "%lf", &dcheck);
682		if (dcheck == value)
683		    break;
684	    }
685	}
686    }
687    else {
688	sprintf(fmt, "%%.%de", d <= 0 ? 0 : d > FLOAT_PREC ? FLOAT_PREC : d);
689	sprintf(stk, fmt, value);
690    }
691
692    /* this "should" never fail */
693    ptr = strchr(stk, 'e');
694    if (ptr) {
695	*ptr++ = '\0';
696	*exponent = atoi(ptr);
697    }
698    else
699	*exponent = 0;
700
701    /* find start of number representation */
702    for (ptr = stk; *ptr && !isdigit(*ptr); ptr++)
703	;
704
705    /* check if did not trim any significant digit,
706     * this may happen because '%.e' puts only one digit before the '.' */
707    if (d > 0 && d < FLOAT_PREC && fabs(value) >= 10.0 &&
708	strlen(ptr) - 1 - !positive <= *exponent) {
709	d += *exponent - (strlen(ptr) - 1 - !positive) + 1;
710	goto parse_double_again;
711    }
712
713    /* this "should" never fail */
714    fract = strchr(ptr, '.');
715    if (fract)
716	*fract++ = '\0';
717
718    /* store number representation in buffer */
719    *buffer = positive ? '+' : '-';
720    strcpy(buffer + 1, ptr);
721    if (fract)
722	strcpy(buffer + strlen(buffer), fract);
723}
724
725static void
726format_integer(char *buffer, long value, int radix)
727{
728    if (radix == 10)
729	sprintf(buffer, "%ld", value);
730    else if (radix == 16)
731	sprintf(buffer, "%lx", value);
732    else if (radix == 8)
733	sprintf(buffer, "%lo", value);
734    else {
735	/* use bignum routine to convert number to string */
736	mpi integer;
737
738	mpi_init(&integer);
739	mpi_seti(&integer, value);
740	mpi_getstr(buffer, &integer, radix);
741	mpi_clear(&integer);
742    }
743}
744
745static int
746LispWriteCPointer(LispObj *stream, void *data)
747{
748    char stk[32];
749
750#ifdef LONG64
751    sprintf(stk, "0x%016lx", (long)data);
752#else
753    sprintf(stk, "0x%08lx", (long)data);
754#endif
755
756    return (LispWriteStr(stream, stk, strlen(stk)));
757}
758
759static int
760LispWriteCString(LispObj *stream, char *string, long length, write_info *info)
761{
762    int result;
763
764    if (!info->print_escape) {
765	char *base, *ptr, *end;
766
767	result = LispWriteChar(stream, '"');
768	for (base = ptr = string, end = string + length; ptr < end; ptr++) {
769	    if (*ptr == '\\' || *ptr == '"') {
770		result += LispWriteStr(stream, base, ptr - base);
771		result += LispWriteChar(stream, '\\');
772		result += LispWriteChar(stream, *ptr);
773		base = ptr + 1;
774	    }
775	}
776	result += LispWriteStr(stream, base, end - base);
777	result += LispWriteChar(stream, '"');
778    }
779    else
780	result = LispWriteStr(stream, string, length);
781
782    return (result);
783}
784
785static int
786LispWriteList(LispObj *stream, LispObj *object, write_info *info, int paren)
787{
788    int length = 0;
789    long circle = 0;
790
791    INCDEPTH();
792    if (info->print_level < 0 || info->level <= info->print_level) {
793	LispObj *car, *cdr;
794	long print_length = info->length;
795
796	if (info->circles && (circle = LispCheckCircle(object, info)) >= 0) {
797	    if (!paren) {
798		length += LispWriteStr(stream, ". ", 2);
799		paren = 1;
800	    }
801	    if (LispPrintCircle(stream, object, circle, &length, info) == 0) {
802		DECDEPTH();
803
804		return (length);
805	    }
806	}
807
808	car = CAR(object);
809	cdr = CDR(object);
810
811	if (cdr == NIL) {
812	    if (paren)
813		length += LispWriteChar(stream, '(');
814	    if (info->print_length < 0 || info->length < info->print_length) {
815		info->length = 0;
816		length += LispDoWriteObject(stream, car, info, 1);
817		info->length = print_length + 1;
818	    }
819	    else
820		length += LispWriteStr(stream, "...", 3);
821	    if (paren)
822		length += LispWriteChar(stream, ')');
823	}
824	else {
825	    if (paren)
826		length += LispWriteChar(stream, '(');
827	    if (info->print_length < 0 || info->length < info->print_length) {
828		info->length = 0;
829		length += LispDoWriteObject(stream, car, info, 1);
830		info->length = print_length + 1;
831		if (!CONSP(cdr)) {
832		    length += LispWriteStr(stream, " . ", 3);
833		    info->length = 0;
834		    length += LispDoWriteObject(stream, cdr, info, 0);
835		}
836		else {
837		    length += LispWriteChar(stream, ' ');
838		    if (info->print_length < 0 ||
839			info->length < info->print_length)
840			length += LispWriteList(stream, cdr, info, 0);
841		    else
842			length += LispWriteStr(stream, "...", 3);
843		}
844	    }
845	    else
846		length += LispWriteStr(stream, "...", 3);
847	    if (paren)
848		length += LispWriteChar(stream, ')');
849	}
850	info->length = print_length;
851    }
852    else
853	length += LispWriteChar(stream, '#');
854    DECDEPTH();
855
856    return (length);
857}
858
859static int
860LispDoWriteObject(LispObj *stream, LispObj *object, write_info *info, int paren)
861{
862    long print_level;
863    int length = 0;
864    char stk[64];
865    const char *string = NULL;
866
867write_again:
868    switch (OBJECT_TYPE(object)) {
869	case LispNil_t:
870	    if (object == NIL)
871		string = Snil->value;
872	    else if (object == T)
873		string = St->value;
874	    else if (object == DOT)
875		string = "#<DOT>";
876	    else if (object == UNSPEC)
877		string = "#<UNSPEC>";
878	    else if (object == UNBOUND)
879		string = "#<UNBOUND>";
880	    else
881		string = "#<ERROR>";
882	    length += LispDoWriteAtom(stream, string, strlen(string),
883				      info->print_case);
884	    break;
885	case LispOpaque_t: {
886	    char *desc = LispIntToOpaqueType(object->data.opaque.type);
887
888	    length += LispWriteChar(stream, '#');
889	    length += LispWriteCPointer(stream, object->data.opaque.data);
890	    length += LispWriteStr(stream, desc, strlen(desc));
891	}   break;
892	case LispAtom_t:
893	    length += LispWriteAtom(stream, object, info);
894	    break;
895	case LispFunction_t:
896	    if (object->data.atom->a_function) {
897		object = object->data.atom->property->fun.function;
898		goto write_lambda;
899	    }
900	    length += LispWriteStr(stream, "#<", 2);
901	    if (object->data.atom->a_compiled)
902		LispDoWriteAtom(stream, "COMPILED", 8, info->print_case);
903	    else if (object->data.atom->a_builtin)
904		LispDoWriteAtom(stream, "BUILTIN", 7, info->print_case);
905	    /* XXX the function does not exist anymore */
906	    /* FIXME not sure if I want this fixed... */
907	    else
908		LispDoWriteAtom(stream, "UNBOUND", 7, info->print_case);
909	    LispDoWriteAtom(stream, "-FUNCTION", 9, info->print_case);
910	    length += LispWriteChar(stream, ' ');
911	    length += LispWriteAtom(stream, object->data.atom->object, info);
912	    length += LispWriteChar(stream, '>');
913	    break;
914	case LispString_t:
915	    length += LispWriteString(stream, object, info);
916	    break;
917	case LispSChar_t:
918	    length += LispWriteCharacter(stream, object, info);
919	    break;
920	case LispDFloat_t:
921	    length += LispWriteFloat(stream, object);
922	    break;
923	case LispFixnum_t:
924	case LispInteger_t:
925	case LispBignum_t:
926	    length += LispWriteInteger(stream, object);
927	    break;
928	case LispRatio_t:
929	    format_integer(stk, object->data.ratio.numerator, 10);
930	    length += LispWriteStr(stream, stk, strlen(stk));
931	    length += LispWriteChar(stream, '/');
932	    format_integer(stk, object->data.ratio.denominator, 10);
933	    length += LispWriteStr(stream, stk, strlen(stk));
934	    break;
935	case LispBigratio_t: {
936	    int sz;
937	    char *ptr;
938
939	    sz = mpi_getsize(mpr_num(object->data.mp.ratio), 10) + 1 +
940		 mpi_getsize(mpr_den(object->data.mp.ratio), 10) + 1 +
941		 (mpi_sgn(mpr_num(object->data.mp.ratio)) < 0);
942	    if (sz > sizeof(stk))
943		ptr = LispMalloc(sz);
944	    else
945		ptr = stk;
946	    mpr_getstr(ptr, object->data.mp.ratio, 10);
947	    length += LispWriteStr(stream, ptr, sz - 1);
948	    if (ptr != stk)
949		LispFree(ptr);
950	}   break;
951	case LispComplex_t:
952	    length += LispWriteStr(stream, "#C(", 3);
953	    length += LispDoWriteObject(stream,
954					object->data.complex.real, info, 0);
955	    length += LispWriteChar(stream, ' ');
956	    length += LispDoWriteObject(stream,
957					object->data.complex.imag, info, 0);
958	    length += LispWriteChar(stream, ')');
959	    break;
960	case LispCons_t:
961	    print_level = info->level;
962	    ++info->level;
963	    length += LispWriteList(stream, object, info, paren);
964	    info->level = print_level;
965	    break;
966	case LispQuote_t:
967	    length += LispWriteChar(stream, '\'');
968	    paren = 1;
969	    object = object->data.quote;
970	    goto write_again;
971	case LispBackquote_t:
972	    length += LispWriteChar(stream, '`');
973	    paren = 1;
974	    object = object->data.quote;
975	    goto write_again;
976	case LispComma_t:
977	    if (object->data.comma.atlist)
978		length += LispWriteStr(stream, ",@", 2);
979	    else
980		length += LispWriteChar(stream, ',');
981	    paren = 1;
982	    object = object->data.comma.eval;
983	    goto write_again;
984	    break;
985	case LispFunctionQuote_t:
986	    length += LispWriteStr(stream, "#'", 2);
987	    paren = 1;
988	    object = object->data.quote;
989	    goto write_again;
990	case LispArray_t:
991	    length += LispWriteArray(stream, object, info);
992	    break;
993	case LispStruct_t:
994	    length += LispWriteStruct(stream, object, info);
995	    break;
996	case LispLambda_t:
997	write_lambda:
998	    switch (object->funtype) {
999		case LispLambda:
1000		    string = "#<LAMBDA ";
1001		    break;
1002		case LispFunction:
1003		    string = "#<FUNCTION ";
1004		    break;
1005		case LispMacro:
1006		    string = "#<MACRO ";
1007		    break;
1008		case LispSetf:
1009		    string = "#<SETF ";
1010		    break;
1011	    }
1012	    length += LispDoWriteAtom(stream, string, strlen(string),
1013				      info->print_case);
1014	    if (object->funtype != LispLambda) {
1015		length += LispWriteAtom(stream, object->data.lambda.name, info);
1016		length += LispWriteChar(stream, ' ');
1017		length += LispWriteAlist(stream, object->data.lambda.name
1018					 ->data.atom->property->alist, info);
1019	    }
1020	    else {
1021		length += LispDoWriteAtom(stream, "NIL", 3, info->print_case);
1022		length += LispWriteChar(stream, ' ');
1023		length += LispWriteAlist(stream, (LispArgList*)object->
1024					 data.lambda.name->data.opaque.data,
1025					 info);
1026	    }
1027	    length += LispWriteChar(stream, ' ');
1028	    length += LispDoWriteObject(stream,
1029					object->data.lambda.code, info, 0);
1030	    length += LispWriteChar(stream, '>');
1031	    break;
1032	case LispStream_t:
1033	    length += LispWriteStr(stream, "#<", 2);
1034	    if (object->data.stream.type == LispStreamFile)
1035		string = "FILE-STREAM ";
1036	    else if (object->data.stream.type == LispStreamString)
1037		string = "STRING-STREAM ";
1038	    else if (object->data.stream.type == LispStreamStandard)
1039		string = "STANDARD-STREAM ";
1040	    else if (object->data.stream.type == LispStreamPipe)
1041		string = "PIPE-STREAM ";
1042	    length += LispDoWriteAtom(stream, string, strlen(string),
1043				      info->print_case);
1044
1045	    if (!object->data.stream.readable && !object->data.stream.writable)
1046		length += LispDoWriteAtom(stream, "CLOSED",
1047					  6, info->print_case);
1048	    else {
1049		if (object->data.stream.readable)
1050		    length += LispDoWriteAtom(stream, "READ",
1051					      4, info->print_case);
1052		if (object->data.stream.writable) {
1053		    if (object->data.stream.readable)
1054			length += LispWriteChar(stream, '-');
1055		    length += LispDoWriteAtom(stream, "WRITE",
1056					      5, info->print_case);
1057		}
1058	    }
1059	    if (object->data.stream.type != LispStreamString) {
1060		length += LispWriteChar(stream, ' ');
1061		length += LispDoWriteObject(stream,
1062					    object->data.stream.pathname,
1063					    info, 1);
1064		/* same address/size for pipes */
1065		length += LispWriteChar(stream, ' ');
1066		length += LispWriteCPointer(stream,
1067					    object->data.stream.source.file);
1068		if (object->data.stream.readable &&
1069		    object->data.stream.type == LispStreamFile &&
1070		    !object->data.stream.source.file->binary) {
1071		    length += LispWriteStr(stream, " @", 2);
1072		    format_integer(stk, object->data.stream.source.file->line, 10);
1073		    length += LispWriteStr(stream, stk, strlen(stk));
1074		}
1075	    }
1076	    length += LispWriteChar(stream, '>');
1077	    break;
1078	case LispPathname_t:
1079	    length += LispWriteStr(stream, "#P", 2);
1080	    paren = 1;
1081	    object = CAR(object->data.quote);
1082	    goto write_again;
1083	case LispPackage_t:
1084	    length += LispDoWriteAtom(stream, "#<PACKAGE ",
1085				      10, info->print_case);
1086	    length += LispWriteStr(stream,
1087				   THESTR(object->data.package.name),
1088				   STRLEN(object->data.package.name));
1089	    length += LispWriteChar(stream, '>');
1090	    break;
1091	case LispRegex_t:
1092	    length += LispDoWriteAtom(stream, "#<REGEX ",
1093				      8, info->print_case);
1094	    length += LispDoWriteObject(stream,
1095					object->data.regex.pattern, info, 1);
1096	    if (object->data.regex.options & RE_NOSPEC)
1097		length += LispDoWriteAtom(stream, " :NOSPEC",
1098					  8, info->print_case);
1099	    if (object->data.regex.options & RE_ICASE)
1100		length += LispDoWriteAtom(stream, " :ICASE",
1101					  7, info->print_case);
1102	    if (object->data.regex.options & RE_NOSUB)
1103		length += LispDoWriteAtom(stream, " :NOSUB",
1104					  7, info->print_case);
1105	    if (object->data.regex.options & RE_NEWLINE)
1106		length += LispDoWriteAtom(stream, " :NEWLINE",
1107					  9, info->print_case);
1108	    length += LispWriteChar(stream, '>');
1109	    break;
1110	case LispBytecode_t:
1111	    length += LispDoWriteAtom(stream, "#<BYTECODE ",
1112				      11, info->print_case);
1113	    length += LispWriteCPointer(stream,
1114					object->data.bytecode.bytecode);
1115	    length += LispWriteChar(stream, '>');
1116	    break;
1117	case LispHashTable_t:
1118	    length += LispDoWriteAtom(stream, "#<HASH-TABLE ",
1119				      13, info->print_case);
1120	    length += LispWriteAtom(stream, object->data.hash.test, info);
1121	    snprintf(stk, sizeof(stk), " %g %g",
1122		     object->data.hash.table->rehash_size,
1123		     object->data.hash.table->rehash_threshold);
1124	    length += LispWriteStr(stream, stk, strlen(stk));
1125	    snprintf(stk, sizeof(stk), " %ld/%ld>",
1126		     object->data.hash.table->count,
1127		     object->data.hash.table->num_entries);
1128	    length += LispWriteStr(stream, stk, strlen(stk));
1129	    break;
1130    }
1131
1132    return (length);
1133}
1134
1135/* return current column number in stream */
1136int
1137LispGetColumn(LispObj *stream)
1138{
1139    LispFile *file;
1140    LispString *string;
1141
1142    check_stream(stream, &file, &string, 0);
1143    if (file != NULL)
1144	return (file->column);
1145    return (string->column);
1146}
1147
1148/* write a character to stream */
1149int
1150LispWriteChar(LispObj *stream, int character)
1151{
1152    LispFile *file;
1153    LispString *string;
1154
1155    check_stream(stream, &file, &string, 1);
1156    if (file != NULL)
1157	return (LispFputc(file, character));
1158
1159    return (LispSputc(string, character));
1160}
1161
1162/* write a character count times to stream */
1163int
1164LispWriteChars(LispObj *stream, int character, int count)
1165{
1166    int length = 0;
1167
1168    if (count > 0) {
1169	char stk[64];
1170	LispFile *file;
1171	LispString *string;
1172
1173	check_stream(stream, &file, &string, 1);
1174	if (count >= sizeof(stk)) {
1175	    memset(stk, character, sizeof(stk));
1176	    for (; count >= sizeof(stk); count -= sizeof(stk)) {
1177		if (file != NULL)
1178		    length += LispFwrite(file, stk, sizeof(stk));
1179		else
1180		    length += LispSwrite(string, stk, sizeof(stk));
1181	    }
1182	}
1183	else
1184	    memset(stk, character, count);
1185
1186	if (count) {
1187	    if (file != NULL)
1188		length += LispFwrite(file, stk, count);
1189	    else
1190		length += LispSwrite(string, stk, count);
1191	}
1192    }
1193
1194    return (length);
1195}
1196
1197/* write a string to stream */
1198int
1199LispWriteStr(LispObj *stream, const char *buffer, long length)
1200{
1201    LispFile *file;
1202    LispString *string;
1203
1204    check_stream(stream, &file, &string, 1);
1205    if (file != NULL)
1206	return (LispFwrite(file, buffer, length));
1207    return (LispSwrite(string, buffer, length));
1208}
1209
1210static int
1211LispDoWriteAtom(LispObj *stream, const char *string, int length, int print_case)
1212{
1213    int bytes = 0, cap = 0;
1214    char buffer[128], *ptr;
1215
1216    switch (print_case) {
1217	case DOWNCASE:
1218	    for (ptr = buffer; length > 0; length--, string++) {
1219		if (isupper(*string))
1220		    *ptr = tolower(*string);
1221		else
1222		    *ptr = *string;
1223		++ptr;
1224		if (ptr - buffer >= sizeof(buffer)) {
1225		    bytes += LispWriteStr(stream, buffer, ptr - buffer);
1226		    ptr = buffer;
1227		}
1228	    }
1229	    if (ptr > buffer)
1230		bytes += LispWriteStr(stream, buffer, ptr - buffer);
1231	    break;
1232	case CAPITALIZE:
1233	    for (ptr = buffer; length > 0; length--, string++) {
1234		if (isalnum(*string)) {
1235		    if (cap && isupper(*string))
1236			*ptr = tolower(*string);
1237		    else
1238			*ptr = *string;
1239		    cap = 1;
1240		}
1241		else {
1242		    *ptr = *string;
1243		    cap = 0;
1244		}
1245		++ptr;
1246		if (ptr - buffer >= sizeof(buffer)) {
1247		    bytes += LispWriteStr(stream, buffer, ptr - buffer);
1248		    ptr = buffer;
1249		}
1250	    }
1251	    if (ptr > buffer)
1252		bytes += LispWriteStr(stream, buffer, ptr - buffer);
1253	    break;
1254	default:
1255	    /* Strings are already stored upcase/quoted */
1256	    bytes += LispWriteStr(stream, string, length);
1257	    break;
1258    }
1259
1260    return (bytes);
1261}
1262
1263static int
1264LispWriteAtom(LispObj *stream, LispObj *object, write_info *info)
1265{
1266    int length = 0;
1267    LispAtom *atom = object->data.atom;
1268    Atom_id id = atom->key;
1269
1270    if (atom->package != PACKAGE) {
1271	if (atom->package == lisp__data.keyword)
1272	    length += LispWriteChar(stream, ':');
1273	else if (atom->package == NULL)
1274	    length += LispWriteStr(stream, "#:", 2);
1275	else {
1276	    /* Check if the symbol is visible */
1277	    int i, visible = 0;
1278
1279	    if (atom->ext) {
1280		for (i = lisp__data.pack->use.length - 1; i >= 0; i--) {
1281		    if (lisp__data.pack->use.pairs[i] == atom->package) {
1282			visible = 1;
1283			break;
1284		    }
1285		}
1286	    }
1287
1288	    if (!visible) {
1289		/* XXX this assumes that package names are always "readable" */
1290		length +=
1291		    LispDoWriteAtom(stream,
1292				    THESTR(atom->package->data.package.name),
1293				    STRLEN(atom->package->data.package.name),
1294				    info->print_case);
1295		length += LispWriteChar(stream, ':');
1296		if (!atom->ext)
1297		    length += LispWriteChar(stream, ':');
1298	    }
1299	}
1300    }
1301    if (atom->unreadable)
1302	length += LispWriteChar(stream, '|');
1303    length += LispDoWriteAtom(stream, id->value, id->length,
1304			      atom->unreadable ? UPCASE : info->print_case);
1305    if (atom->unreadable)
1306	length += LispWriteChar(stream, '|');
1307
1308    return (length);
1309}
1310
1311static int
1312LispWriteInteger(LispObj *stream, LispObj *object)
1313{
1314    return (LispFormatInteger(stream, object, 10, 0, 0, 0, 0, 0, 0));
1315}
1316
1317static int
1318LispWriteCharacter(LispObj *stream, LispObj *object, write_info *info)
1319{
1320    return (LispFormatCharacter(stream, object, !info->print_escape, 0));
1321}
1322
1323static int
1324LispWriteString(LispObj *stream, LispObj *object, write_info *info)
1325{
1326    return (LispWriteCString(stream, THESTR(object), STRLEN(object), info));
1327}
1328
1329static int
1330LispWriteFloat(LispObj *stream, LispObj *object)
1331{
1332    double value = DFLOAT_VALUE(object);
1333
1334    if (value == 0.0 || (fabs(value) < 1.0E7 && fabs(value) > 1.0E-4))
1335	return (LispFormatFixedFloat(stream, object, 0, 0, NULL, 0, 0, 0));
1336
1337    return (LispDoFormatExponentialFloat(stream, object, 0, 0, NULL,
1338					 0, 1, 0, ' ', 'E', 0));
1339}
1340
1341static int
1342LispWriteArray(LispObj *stream, LispObj *object, write_info *info)
1343{
1344    int length = 0;
1345    long print_level = info->level, circle;
1346
1347    if (info->circles && (circle = LispCheckCircle(object, info)) >= 0 &&
1348	LispPrintCircle(stream, object, circle, &length, info) == 0)
1349	return (length);
1350
1351    if (object->data.array.rank == 0) {
1352	length += LispWriteStr(stream, "#0A", 3);
1353	length += LispDoWriteObject(stream, object->data.array.list, info, 1);
1354	return (length);
1355    }
1356
1357    INCDEPTH();
1358    ++info->level;
1359    if (info->print_level < 0 || info->level <= info->print_level) {
1360	if (object->data.array.rank == 1)
1361	    length += LispWriteStr(stream, "#(", 2);
1362	else {
1363	    char stk[32];
1364
1365	    format_integer(stk, object->data.array.rank, 10);
1366	    length += LispWriteChar(stream, '#');
1367	    length += LispWriteStr(stream, stk, strlen(stk));
1368	    length += LispWriteStr(stream, "A(", 2);
1369	}
1370
1371	if (!object->data.array.zero) {
1372	    long print_length = info->length, local_length = 0;
1373
1374	    if (object->data.array.rank == 1) {
1375		LispObj *ary;
1376		long count;
1377
1378		for (ary = object->data.array.dim, count = 1;
1379		     ary != NIL; ary = CDR(ary))
1380		    count *= FIXNUM_VALUE(CAR(ary));
1381		for (ary = object->data.array.list; count > 0;
1382		     ary = CDR(ary), count--) {
1383		    if (info->print_length < 0 ||
1384			++local_length <= info->print_length) {
1385			info->length = 0;
1386			length += LispDoWriteObject(stream, CAR(ary), info, 1);
1387		    }
1388		    else {
1389			length += LispWriteStr(stream, "...", 3);
1390			break;
1391		    }
1392		    if (count - 1 > 0)
1393			length += LispWriteChar(stream, ' ');
1394		}
1395	    }
1396	    else {
1397		LispObj *ary;
1398		int i, k, rank, *dims, *loop;
1399
1400		rank = object->data.array.rank;
1401		dims = LispMalloc(sizeof(int) * rank);
1402		loop = LispCalloc(1, sizeof(int) * (rank - 1));
1403
1404		/* fill dim */
1405		for (i = 0, ary = object->data.array.dim; ary != NIL;
1406		     i++, ary = CDR(ary))
1407		    dims[i] = FIXNUM_VALUE(CAR(ary));
1408
1409		i = 0;
1410		ary = object->data.array.list;
1411		while (loop[0] < dims[0]) {
1412		    if (info->print_length < 0 ||
1413			local_length < info->print_length) {
1414			for (; i < rank - 1; i++)
1415			    length += LispWriteChar(stream, '(');
1416			--i;
1417			for (;;) {
1418			    ++loop[i];
1419			    if (i && loop[i] >= dims[i])
1420				loop[i] = 0;
1421			    else
1422				break;
1423			    --i;
1424			}
1425			for (k = 0; k < dims[rank - 1] - 1;
1426			     k++, ary = CDR(ary)) {
1427			    if (info->print_length < 0 ||
1428				k < info->print_length) {
1429				++local_length;
1430				info->length = 0;
1431				length += LispDoWriteObject(stream,
1432							    CAR(ary), info, 1);
1433				length += LispWriteChar(stream, ' ');
1434			    }
1435			}
1436			if (info->print_length < 0 || k < info->print_length) {
1437			    ++local_length;
1438			    info->length = 0;
1439			    length += LispDoWriteObject(stream,
1440							CAR(ary), info, 0);
1441			}
1442			else
1443			    length += LispWriteStr(stream,  "...", 3);
1444			for (k = rank - 1; k > i; k--)
1445			    length += LispWriteChar(stream, ')');
1446			if (loop[0] < dims[0])
1447			    length += LispWriteChar(stream,  ' ');
1448			ary = CDR(ary);
1449		    }
1450		    else {
1451			++local_length;
1452			length += LispWriteStr(stream,	"...)", 4);
1453			for (; local_length < dims[0] - 1; local_length++)
1454			    length += LispWriteStr(stream,  " ...)", 5);
1455			if (local_length <= dims[0])
1456			    length += LispWriteStr(stream,  " ...", 4);
1457			break;
1458		    }
1459		}
1460		LispFree(dims);
1461		LispFree(loop);
1462	    }
1463	    info->length = print_length;
1464	}
1465	length += LispWriteChar(stream, ')');
1466    }
1467    else
1468	length += LispWriteChar(stream, '#');
1469    info->level = print_level;
1470    DECDEPTH();
1471
1472    return (length);
1473}
1474
1475static int
1476LispWriteStruct(LispObj *stream, LispObj *object, write_info *info)
1477{
1478    int length;
1479    long circle;
1480    LispObj *symbol;
1481    LispObj *def = object->data.struc.def;
1482    LispObj *field = object->data.struc.fields;
1483
1484    if (info->circles && (circle = LispCheckCircle(object, info)) >= 0 &&
1485	LispPrintCircle(stream, object, circle, &length, info) == 0)
1486	return (length);
1487
1488    INCDEPTH();
1489    length = LispWriteStr(stream, "#S(", 3);
1490    symbol = SYMBOLP(CAR(def)) ? CAR(def) : CAAR(def);
1491    length += LispWriteAtom(stream, symbol, info);
1492    def = CDR(def);
1493    for (; def != NIL; def = CDR(def), field = CDR(field)) {
1494	length += LispWriteChar(stream, ' ');
1495	symbol = SYMBOLP(CAR(def)) ? CAR(def) : CAAR(def);
1496	length += LispWriteAtom(stream, symbol, info);
1497	length += LispWriteChar(stream, ' ');
1498	length += LispDoWriteObject(stream, CAR(field), info, 1);
1499    }
1500    length += LispWriteChar(stream, ')');
1501    DECDEPTH();
1502
1503    return (length);
1504}
1505
1506int
1507LispFormatInteger(LispObj *stream, LispObj *object, int radix,
1508		  int atsign, int collon, int mincol,
1509		  int padchar, int commachar, int commainterval)
1510{
1511    char stk[128], *str = stk;
1512    int i, length, sign, intervals;
1513
1514    if (LONGINTP(object))
1515	format_integer(stk, LONGINT_VALUE(object), radix);
1516    else {
1517	if (mpi_getsize(object->data.mp.integer, radix) >= sizeof(stk))
1518	    str = mpi_getstr(NULL, object->data.mp.integer, radix);
1519	else
1520	    mpi_getstr(str, object->data.mp.integer, radix);
1521    }
1522
1523    sign = *str == '-';
1524    length = strlen(str);
1525
1526    /* if collon, update length for the number of commachars to be printed */
1527    if (collon && commainterval > 0 && commachar) {
1528	intervals = length / commainterval;
1529	length += intervals;
1530    }
1531    else
1532	intervals = 0;
1533
1534    /* if sign must be printed, and number is positive */
1535    if (atsign && !sign)
1536	++length;
1537
1538    /* if need padding */
1539    if (padchar && mincol > length)
1540	LispWriteChars(stream, padchar, mincol - length);
1541
1542    /* if need to print number sign */
1543    if (sign || atsign)
1544	LispWriteChar(stream, sign ? '-' : '+');
1545
1546    /* if need to print commas to separate groups of numbers */
1547    if (intervals) {
1548	int j;
1549	char *ptr;
1550
1551	i = (length - atsign) - intervals;
1552	j = i % commainterval;
1553	/* make the loop below easier */
1554	if (j == 0)
1555	    j = commainterval;
1556	i -= j;
1557	ptr = str + sign;
1558	for (; j > 0; j--, ptr++)
1559	    LispWriteChar(stream, *ptr);
1560	for (; i > 0; i -= commainterval) {
1561	    LispWriteChar(stream, commachar);
1562	    for (j = 0; j < commainterval; j++, ptr++)
1563		LispWriteChar(stream, *ptr);
1564	}
1565    }
1566    /* else, just print the string */
1567    else
1568	LispWriteStr(stream, str + sign, length - sign);
1569
1570    /* if number required more than sizeof(stk) bytes */
1571    if (str != stk)
1572	LispFree(str);
1573
1574    return (length);
1575}
1576
1577int
1578LispFormatRomanInteger(LispObj *stream, long value, int new_roman)
1579{
1580    char stk[32];
1581    int length;
1582
1583    length = 0;
1584    while (value > 1000) {
1585	stk[length++] = 'M';
1586	value -= 1000;
1587    }
1588    if (new_roman) {
1589	if (value >= 900) {
1590	    strcpy(stk + length, "CM");
1591	    length += 2,
1592	    value -= 900;
1593	}
1594	else if (value < 500 && value >= 400) {
1595	    strcpy(stk + length, "CD");
1596	    length += 2;
1597	    value -= 400;
1598	}
1599    }
1600    if (value >= 500) {
1601	stk[length++] = 'D';
1602	value -= 500;
1603    }
1604    while (value >= 100) {
1605	stk[length++] = 'C';
1606	value -= 100;
1607    }
1608    if (new_roman) {
1609	if (value >= 90) {
1610	    strcpy(stk + length, "XC");
1611	    length += 2,
1612	    value -= 90;
1613	}
1614	else if (value < 50 && value >= 40) {
1615	    strcpy(stk + length, "XL");
1616	    length += 2;
1617	    value -= 40;
1618	}
1619    }
1620    if (value >= 50) {
1621	stk[length++] = 'L';
1622	value -= 50;
1623    }
1624    while (value >= 10) {
1625	stk[length++] = 'X';
1626	value -= 10;
1627    }
1628    if (new_roman) {
1629	if (value == 9) {
1630	    strcpy(stk + length, "IX");
1631	    length += 2,
1632	    value -= 9;
1633	}
1634	else if (value == 4) {
1635	    strcpy(stk + length, "IV");
1636	    length += 2;
1637	    value -= 4;
1638	}
1639    }
1640    if (value >= 5) {
1641	stk[length++] = 'V';
1642	value -= 5;
1643    }
1644    while (value) {
1645	stk[length++] = 'I';
1646	--value;
1647    }
1648
1649    stk[length] = '\0';
1650
1651    return (LispWriteStr(stream, stk, length));
1652}
1653
1654int
1655LispFormatEnglishInteger(LispObj *stream, long number, int ordinal)
1656{
1657    static const char *ds[] = {
1658	"",	      "one",	   "two",	 "three",      "four",
1659	"five",       "six",	   "seven",	 "eight",      "nine",
1660	"ten",	      "eleven",    "twelve",	 "thirteen",   "fourteen",
1661	"fifteen",    "sixteen",   "seventeen",  "eighteen",   "nineteen"
1662    };
1663    static const char *dsth[] = {
1664	"",	      "first",	   "second",	  "third",	"fourth",
1665	"fifth",      "sixth",	   "seventh",	  "eighth",	"ninth",
1666	"tenth",      "eleventh",  "twelfth",	  "thirteenth", "fourteenth",
1667	 "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth"
1668    };
1669    static const char *hs[] = {
1670	"",	      "",	   "twenty",	  "thirty",	"forty",
1671	"fifty",      "sixty",	   "seventy",	  "eighty",	"ninety"
1672    };
1673    static const char *hsth[] = {
1674	"",	      "",	   "twentieth",   "thirtieth",	"fortieth",
1675       "fiftieth",    "sixtieth",  "seventieth",  "eightieth",	"ninetieth"
1676    };
1677    static const char *ts[] = {
1678	"",	      "thousand",   "million"
1679    };
1680    static const char *tsth[] = {
1681	"",	     "thousandth", "millionth"
1682    };
1683    char stk[256];
1684    int length, sign;
1685
1686    sign = number < 0;
1687    if (sign)
1688	number = -number;
1689    length = 0;
1690
1691#define SIGNLEN		6	/* strlen("minus ") */
1692    if (sign) {
1693	strcpy(stk, "minus ");
1694	length += SIGNLEN;
1695    }
1696    else if (number == 0) {
1697	if (ordinal) {
1698	    strcpy(stk, "zeroth");
1699	    length += 6;	/* strlen("zeroth") */
1700	}
1701	else {
1702	    strcpy(stk, "zero");
1703	    length += 4;	/* strlen("zero") */
1704	}
1705    }
1706    for (;;) {
1707	int count, temp;
1708	const char *t, *h, *d;
1709	long value = number;
1710
1711	for (count = 0; value >= 1000; value /= 1000, count++)
1712	    ;
1713
1714	t = ds[value / 100];
1715	if (ordinal && !count && (value % 10) == 0)
1716	    h = hsth[(value % 100) / 10];
1717	else
1718	    h = hs[(value % 100) / 10];
1719
1720	if (ordinal && !count)
1721	    d = *h ? dsth[value % 10] : dsth[value % 20];
1722	else
1723	    d = *h ? ds[value % 10] : ds[value % 20];
1724
1725	if (((!sign && length) || length > SIGNLEN) && (*t || *h || *d)) {
1726	    if (!ordinal || count || *h || *t) {
1727		strcpy(stk + length, ", ");
1728		length += 2;
1729	    }
1730	    else {
1731		strcpy(stk + length, " ");
1732		++length;
1733	    }
1734	}
1735
1736	if (*t) {
1737	    if (ordinal && !count && (value % 100) == 0)
1738		temp = sprintf(stk + length, "%s hundredth", t);
1739	    else
1740		temp = sprintf(stk + length, "%s hundred", t);
1741	    length += temp;
1742	}
1743
1744	if (*h) {
1745	    if (*t) {
1746		if (ordinal && !count) {
1747		    strcpy(stk + length, " ");
1748		    ++length;
1749		}
1750		else {
1751		    strcpy(stk + length, " and ");
1752		    length += 5;	/* strlen(" and ") */
1753		}
1754	    }
1755	    strcpy(stk + length, h);
1756	    length += strlen(h);
1757	}
1758
1759	if (*d) {
1760	    if (*h) {
1761		strcpy(stk + length, "-");
1762		++length;
1763	    }
1764	    else if (*t) {
1765		if (ordinal && !count) {
1766		    strcpy(stk + length, " ");
1767		    ++length;
1768		}
1769		else {
1770		    strcpy(stk + length, " and ");
1771		    length += 5;	/* strlen(" and ") */
1772		}
1773	    }
1774	    strcpy(stk + length, d);
1775	    length += strlen(d);
1776	}
1777
1778	if (!count)
1779	    break;
1780	else
1781	    temp = count;
1782
1783	if (count > 1) {
1784	    value *= 1000;
1785	    while (--count)
1786		value *= 1000;
1787	    number -= value;
1788	}
1789	else
1790	    number %= 1000;
1791
1792	if (ordinal && number == 0 && !*t && !*h)
1793	    temp = sprintf(stk + length, " %s", tsth[temp]);
1794	else
1795	    temp = sprintf(stk + length, " %s", ts[temp]);
1796	length += temp;
1797
1798	if (!number)
1799	    break;
1800    }
1801
1802    return (LispWriteStr(stream, stk, length));
1803}
1804
1805int
1806LispFormatCharacter(LispObj *stream, LispObj *object,
1807		    int atsign, int collon)
1808{
1809    int length = 0;
1810    int ch = SCHAR_VALUE(object);
1811
1812    if (atsign && !collon)
1813	length += LispWriteStr(stream, "#\\", 2);
1814    if ((atsign || collon) && (ch <= ' ' || ch == 0177)) {
1815	const char *name = LispChars[ch].names[0];
1816
1817	length += LispWriteStr(stream, name, strlen(name));
1818    }
1819    else
1820	length += LispWriteChar(stream, ch);
1821
1822    return (length);
1823}
1824
1825/* returns 1 if string size must grow, done inplace */
1826static int
1827float_string_inc(char *buffer, int offset)
1828{
1829    int i;
1830
1831    for (i = offset; i >= 0; i--) {
1832	if (buffer[i] == '9')
1833	    buffer[i] = '0';
1834	else if (buffer[i] != '.') {
1835	    ++buffer[i];
1836	    break;
1837	}
1838    }
1839    if (i < 0) {
1840	int length = strlen(buffer);
1841
1842	/* string size must change */
1843	memmove(buffer + 1, buffer, length + 1);
1844	buffer[0] = '1';
1845
1846	return (1);
1847    }
1848
1849    return (0);
1850}
1851
1852int
1853LispFormatFixedFloat(LispObj *stream, LispObj *object,
1854		     int atsign, int w, int *pd, int k, int overflowchar,
1855		     int padchar)
1856{
1857    char buffer[512], stk[64];
1858    int sign, exponent, length, offset, d = pd ? *pd : FLOAT_PREC, again;
1859    double value = DFLOAT_VALUE(object);
1860
1861    if (value == 0.0) {
1862	exponent = k = 0;
1863	strcpy(stk, "+0");
1864    }
1865    else
1866	/* calculate format parameters, adjusting scale factor */
1867	parse_double(stk, &exponent, value, d + 1 + k);
1868
1869    /* make sure k won't cause overflow */
1870    if (k > 128)
1871	k = 128;
1872    else if (k < -128)
1873	k = -128;
1874
1875    /* make sure d won't cause overflow */
1876    if (d > 128)
1877	d = 128;
1878    else if (d < -128)
1879	d = -128;
1880
1881    /* adjust scale factor, exponent is used as an index in stk */
1882    exponent += k + 1;
1883
1884    /* how many bytes in float representation */
1885    length = strlen(stk) - 1;
1886
1887    /* need to print a sign? */
1888    sign = atsign || (stk[0] == '-');
1889
1890    /* format number, cannot overflow, as control variables were checked */
1891    offset = 0;
1892    if (sign)
1893	buffer[offset++] = stk[0];
1894    if (exponent > 0) {
1895	if (exponent > length) {
1896	    memcpy(buffer + offset, stk + 1, length);
1897	    memset(buffer + offset + length, '0', exponent - length);
1898	}
1899	else
1900	    memcpy(buffer + offset, stk + 1, exponent);
1901	offset += exponent;
1902	buffer[offset++] = '.';
1903	if (length > exponent) {
1904	    memcpy(buffer + offset, stk + 1 + exponent, length - exponent);
1905	    offset += length - exponent;
1906	}
1907	else
1908	    buffer[offset++] = '0';
1909    }
1910    else {
1911	buffer[offset++] = '0';
1912	buffer[offset++] = '.';
1913	while (exponent < 0) {
1914	    buffer[offset++] = '0';
1915	    exponent++;
1916	}
1917	memcpy(buffer + offset, stk + 1, length);
1918	offset += length;
1919    }
1920    buffer[offset] = '\0';
1921
1922    again = 0;
1923fixed_float_check_again:
1924    /* make sure only d digits are printed after decimal point */
1925    if (d > 0) {
1926	char *dptr = strchr(buffer, '.');
1927
1928	length = strlen(dptr) - 1;
1929	/* check if need to remove excess digits */
1930	if (length > d) {
1931	    int digit;
1932
1933	    offset = (dptr - buffer) + 1 + d;
1934	    digit = buffer[offset];
1935
1936	    /* remove extra digits */
1937	    buffer[offset] = '\0';
1938
1939	    /* check if need to round */
1940	    if (!again && offset > 1 && isdigit(digit) && digit >= '5' &&
1941		isdigit(buffer[offset - 1]) &&
1942		float_string_inc(buffer, offset - 1))
1943		++offset;
1944	}
1945	/* check if need to add extra zero digits to fill space */
1946	else if (length < d) {
1947	    offset += d - length;
1948	    for (++length; length <= d; length++)
1949		dptr[length] = '0';
1950	    dptr[length] = '\0';
1951	}
1952    }
1953    else {
1954	/* no digits after decimal point */
1955	int digit, inc = 0;
1956	char *dptr = strchr(buffer, '.') + 1;
1957
1958	digit = *dptr;
1959	if (!again && digit >= '5' && dptr >= buffer + 2 && isdigit(dptr[-2]))
1960	    inc = float_string_inc(buffer, dptr - buffer - 2);
1961
1962	offset = (dptr - buffer) + inc;
1963	buffer[offset] = '\0';
1964    }
1965
1966    /* if d was not specified, remove any extra zeros */
1967    if (pd == NULL) {
1968	while (offset > 2 && buffer[offset - 2] != '.' &&
1969	       buffer[offset - 1] == '0')
1970	    --offset;
1971	buffer[offset] = '\0';
1972    }
1973
1974    if (w > 0 && offset > w) {
1975	/* first check if can remove extra fractional digits */
1976	if (pd == NULL) {
1977	    char *ptr = strchr(buffer, '.') + 1;
1978
1979	    if (ptr - buffer < w) {
1980		d = w - (ptr - buffer);
1981		goto fixed_float_check_again;
1982	    }
1983	}
1984
1985	/* remove leading "zero" to save space */
1986 	if ((!sign && buffer[0] == '0') || (sign && buffer[1] == '0')) {
1987	    /* ending nul also copied */
1988	    memmove(buffer + sign, buffer + sign + 1, offset);
1989	    --offset;
1990	}
1991	/* remove leading '+' to "save" space */
1992	if (offset > w && buffer[0] == '+') {
1993	    /* ending nul also copied */
1994	    memmove(buffer, buffer + 1, offset);
1995	    --offset;
1996	}
1997    }
1998
1999    /* if cannot represent number in given width */
2000    if (overflowchar && offset > w) {
2001	again = 1;
2002	goto fixed_float_overflow;
2003    }
2004
2005    length = 0;
2006    /* print padding if required */
2007    if (w > offset)
2008	length += LispWriteChars(stream, padchar, w - offset);
2009
2010    /* print float number representation */
2011    return (LispWriteStr(stream, buffer, offset) + length);
2012
2013fixed_float_overflow:
2014    return (LispWriteChars(stream, overflowchar, w));
2015}
2016
2017int
2018LispFormatExponentialFloat(LispObj *stream, LispObj *object,
2019			   int atsign, int w, int *pd, int e, int k,
2020			   int overflowchar, int padchar, int exponentchar)
2021{
2022    return (LispDoFormatExponentialFloat(stream, object, atsign, w,
2023					 pd, e, k, overflowchar, padchar,
2024					 exponentchar, 1));
2025}
2026
2027int
2028LispDoFormatExponentialFloat(LispObj *stream, LispObj *object,
2029			     int atsign, int w, int *pd, int e, int k,
2030			     int overflowchar, int padchar, int exponentchar,
2031			     int format)
2032{
2033    char buffer[512], stk[64];
2034    int sign, exponent, length, offset, d = pd ? *pd : FLOAT_PREC;
2035    double value = DFLOAT_VALUE(object);
2036
2037    if (value == 0.0) {
2038	exponent = 0;
2039	k = 1;
2040	strcpy(stk, "+0");
2041    }
2042    else
2043	/* calculate format parameters, adjusting scale factor */
2044	parse_double(stk, &exponent, value, d + k - 1);
2045
2046    /* set e to a value that won't overflow */
2047    if (e > 16)
2048	e = 16;
2049
2050    /* set k to a value that won't overflow */
2051    if (k > 128)
2052	k = 128;
2053    else if (k < -128)
2054	k = -128;
2055
2056    /* set d to a value that won't overflow */
2057    if (d > 128)
2058	d = 128;
2059    else if (d < -128)
2060	d = -128;
2061
2062    /* how many bytes in float representation */
2063    length = strlen(stk) - 1;
2064
2065    /* need to print a sign? */
2066    sign = atsign || (stk[0] == '-');
2067
2068    /* adjust number of digits after decimal point */
2069    if (k > 0)
2070	d -= k - 1;
2071
2072    /* adjust exponent, based on scale factor */
2073    exponent -= k - 1;
2074
2075    /* format number, cannot overflow, as control variables were checked */
2076    offset = 0;
2077    if (sign)
2078	buffer[offset++] = stk[0];
2079    if (k > 0) {
2080	if (k > length) {
2081	    memcpy(buffer + offset, stk + 1, length);
2082	    offset += length;
2083	}
2084	else {
2085	    memcpy(buffer + offset, stk + 1, k);
2086	    offset += k;
2087	}
2088	buffer[offset++] = '.';
2089	if (length > k) {
2090	    memcpy(buffer + offset, stk + 1 + k, length - k);
2091	    offset += length - k;
2092	}
2093 	else
2094	    buffer[offset++] = '0';
2095    }
2096    else {
2097	int tmp = k;
2098
2099	buffer[offset++] = '0';
2100	buffer[offset++] = '.';
2101	while (tmp < 0) {
2102	    buffer[offset++] = '0';
2103	    tmp++;
2104	}
2105	memcpy(buffer + offset, stk + 1, length);
2106	offset += length;
2107    }
2108
2109    /* if format, then always add a sign to exponent */
2110    buffer[offset++] = exponentchar;
2111    if (format || exponent < 0)
2112	buffer[offset++] = exponent < 0 ? '-' : '+';
2113
2114    /* XXX destroy stk contents */
2115    sprintf(stk, "%%0%dd", e);
2116    /* format scale factor*/
2117    length = sprintf(buffer + offset, stk,
2118		     exponent < 0 ? -exponent : exponent);
2119    /* check for overflow in exponent */
2120    if (length > e && overflowchar)
2121	goto exponential_float_overflow;
2122    offset += length;
2123
2124    /* make sure only d digits are printed after decimal point */
2125    if (d > 0) {
2126	int currd;
2127	char *dptr = strchr(buffer, '.'),
2128	     *eptr = strchr(dptr, exponentchar);
2129
2130	currd = eptr - dptr - 1;
2131	length = strlen(eptr);
2132
2133	/* check if need to remove excess digits */
2134	if (currd > d) {
2135	    int digit, dpos;
2136
2137	    dpos = offset = (dptr - buffer) + 1 + d;
2138	    digit = buffer[offset];
2139
2140	    memmove(buffer + offset, eptr, length + 1);
2141	    /* also copy ending nul character */
2142
2143	    /* adjust offset to length of total string */
2144	    offset += length;
2145
2146	    /* check if need to round */
2147	    if (dpos > 1 && isdigit(digit) && digit >= '5' &&
2148		isdigit(buffer[dpos - 1]) &&
2149		float_string_inc(buffer, dpos - 1))
2150		++offset;
2151	}
2152	/* check if need to add extra zero digits to fill space */
2153	else if (pd && currd < d) {
2154	    memmove(eptr + d - currd, eptr, length + 1);
2155	    /* also copy ending nul character */
2156
2157	    offset += d - currd;
2158	    for (++currd; currd <= d; currd++)
2159		dptr[currd] = '0';
2160	}
2161	/* check if need to remove zeros */
2162	else if (pd == NULL) {
2163	    int zeros = 1;
2164
2165	    while (eptr[-zeros] == '0')
2166		++zeros;
2167	    if (eptr[-zeros] == '.')
2168		--zeros;
2169	    if (zeros > 1) {
2170		memmove(eptr - zeros + 1, eptr, length + 1);
2171		offset -= zeros - 1;
2172	    }
2173	}
2174    }
2175    else {
2176	/* no digits after decimal point */
2177	int digit, inc = 0;
2178	char *dptr = strchr(buffer, '.'),
2179	     *eptr = strchr(dptr, exponentchar);
2180
2181	digit = dptr[1];
2182
2183	offset = (dptr - buffer) + 1;
2184	length = strlen(eptr);
2185	memmove(buffer + offset, eptr, length + 1);
2186	/* also copy ending nul character */
2187
2188 	if (digit >= '5' && dptr >= buffer + 2 &&
2189	    isdigit(dptr[-2]))
2190	    inc = float_string_inc(buffer, dptr - buffer - 2);
2191
2192	/* adjust offset to length of total string */
2193	offset += length + inc;
2194    }
2195
2196    if (w > 0 && offset > w) {
2197	/* remove leading "zero" to save space */
2198	if ((!sign && buffer[0] == '0') || (sign && buffer[1] == '0')) {
2199	    /* ending nul also copied */
2200	    memmove(buffer + sign, buffer + sign + 1, offset);
2201	    --offset;
2202	}
2203	/* remove leading '+' to "save" space */
2204	if (offset > w && buffer[0] == '+') {
2205	    /* ending nul also copied */
2206	    memmove(buffer, buffer + 1, offset);
2207	    --offset;
2208	}
2209    }
2210
2211    /* if cannot represent number in given width */
2212    if (overflowchar && offset > w)
2213	goto exponential_float_overflow;
2214
2215    length = 0;
2216    /* print padding if required */
2217    if (w > offset)
2218	length += LispWriteChars(stream, padchar, w - offset);
2219
2220    /* print float number representation */
2221    return (LispWriteStr(stream, buffer, offset) + length);
2222
2223exponential_float_overflow:
2224    return (LispWriteChars(stream, overflowchar, w));
2225}
2226
2227int
2228LispFormatGeneralFloat(LispObj *stream, LispObj *object,
2229		       int atsign, int w, int *pd, int e, int k,
2230		       int overflowchar, int padchar, int exponentchar)
2231{
2232    char stk[64];
2233    int length, exponent, n, dd, ee, ww, d = pd ? *pd : FLOAT_PREC;
2234    double value = DFLOAT_VALUE(object);
2235
2236    if (value == 0.0) {
2237	exponent = 0;
2238	n = 0;
2239	d = 1;
2240	strcpy(stk, "+0");
2241    }
2242    else {
2243	/* calculate format parameters, adjusting scale factor */
2244	parse_double(stk, &exponent, value, d + k - 1);
2245	n = exponent + 1;
2246    }
2247
2248    /* Let ee equal e+2, or 4 if e is omitted. */
2249    if (e)
2250	ee = e + 2;
2251    else
2252	ee = 4;
2253
2254    /* Let ww equal w-ee, or nil if w is omitted. */
2255    if (w)
2256	ww = w - ee;
2257    else
2258	ww = 0;
2259
2260    dd = d - n;
2261    if (d >= dd && dd >= 0) {
2262	length = LispFormatFixedFloat(stream, object, atsign, ww,
2263				      &dd, 0, overflowchar, padchar);
2264
2265	/* ~ee@T */
2266	length += LispWriteChars(stream, padchar, ee);
2267    }
2268    else
2269	length = LispFormatExponentialFloat(stream, object, atsign,
2270					    w, pd, e, k, overflowchar,
2271					    padchar, exponentchar);
2272
2273    return (length);
2274}
2275
2276int
2277LispFormatDollarFloat(LispObj *stream, LispObj *object,
2278		      int atsign, int collon, int d, int n, int w, int padchar)
2279{
2280    char buffer[512], stk[64];
2281    int sign, exponent, length, offset;
2282    double value = DFLOAT_VALUE(object);
2283
2284    if (value == 0.0) {
2285	exponent = 0;
2286	strcpy(stk, "+0");
2287    }
2288    else
2289	/* calculate format parameters, adjusting scale factor */
2290	parse_double(stk, &exponent, value, d == 0 ? FLOAT_PREC : d + 1);
2291
2292    /* set d to a "sane" value */
2293    if (d > 128)
2294	d = 128;
2295
2296    /* set n to a "sane" value */
2297    if (n > 128)
2298	n = 128;
2299
2300    /* use exponent as index in stk */
2301    ++exponent;
2302
2303    /* don't put sign in buffer,
2304     * if collon specified, must go before padding */
2305    sign = atsign || (stk[0] == '-');
2306
2307    offset = 0;
2308
2309    /* pad with zeros if required */
2310    if (exponent > 0)
2311	n -= exponent;
2312    while (n > 0) {
2313	buffer[offset++] = '0';
2314	n--;
2315    }
2316
2317    /* how many bytes in float representation */
2318    length = strlen(stk) - 1;
2319
2320    if (exponent > 0) {
2321	if (exponent > length) {
2322	    memcpy(buffer + offset, stk + 1, length);
2323	    memset(buffer + offset + length, '0', exponent - length);
2324	}
2325	else
2326	    memcpy(buffer + offset, stk + 1, exponent);
2327	offset += exponent;
2328	buffer[offset++] = '.';
2329	if (length > exponent) {
2330	    memcpy(buffer + offset, stk + 1 + exponent, length - exponent);
2331	    offset += length - exponent;
2332	}
2333	else
2334	    buffer[offset++] = '0';
2335    }
2336    else {
2337	if (n > 0)
2338	    buffer[offset++] = '0';
2339	buffer[offset++] = '.';
2340	while (exponent < 0) {
2341	    buffer[offset++] = '0';
2342	    exponent++;
2343	}
2344	memcpy(buffer + offset, stk + 1, length);
2345	offset += length;
2346    }
2347    buffer[offset] = '\0';
2348
2349    /* make sure only d digits are printed after decimal point */
2350    if (d > 0) {
2351	char *dptr = strchr(buffer, '.');
2352
2353	length = strlen(dptr) - 1;
2354	/* check if need to remove excess digits */
2355	if (length > d) {
2356	    int digit;
2357
2358	    offset = (dptr - buffer) + 1 + d;
2359	    digit = buffer[offset];
2360
2361	    /* remove extra digits */
2362	    buffer[offset] = '\0';
2363
2364	    /* check if need to round */
2365	    if (offset > 1 && isdigit(digit) && digit >= '5' &&
2366		isdigit(buffer[offset - 1]) &&
2367		float_string_inc(buffer, offset - 1))
2368		++offset;
2369	}
2370	/* check if need to add extra zero digits to fill space */
2371	else if (length < d) {
2372	    offset += d - length;
2373	    for (++length; length <= d; length++)
2374		dptr[length] = '0';
2375	    dptr[length] = '\0';
2376	}
2377    }
2378    else {
2379	/* no digits after decimal point */
2380	int digit, inc = 0;
2381	char *dptr = strchr(buffer, '.') + 1;
2382
2383	digit = *dptr;
2384	if (digit >= '5' && dptr >= buffer + 2 && isdigit(dptr[-2]))
2385	    inc = float_string_inc(buffer, dptr - buffer - 2);
2386
2387	offset = (dptr - buffer) + inc;
2388	buffer[offset] = '\0';
2389    }
2390
2391    length = 0;
2392    if (sign) {
2393	++offset;
2394	if (atsign && collon)
2395	    length += LispWriteChar(stream, value >= 0.0 ? '+' : '-');
2396    }
2397
2398    /* print padding if required */
2399    if (w > offset)
2400	length += LispWriteChars(stream, padchar, w - offset);
2401
2402    if (atsign && !collon)
2403	length += LispWriteChar(stream, value >= 0.0 ? '+' : '-');
2404
2405    /* print float number representation */
2406    return (LispWriteStr(stream, buffer, offset) + length);
2407}
2408