write.c revision 5dfecf96 
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*, 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    char *name;
526    int i, length = 0, need_space = 0;
527
528#define WRITE_ATOM(object)						\
529    name = ATOMID(object);						\
530    length += LispDoWriteAtom(stream, name, strlen(name),		\
531			      info->print_case)
532#define WRITE_STRING(string)						\
533    length += LispDoWriteAtom(stream, string, strlen(string),		\
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_STRING(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, 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_STRING(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_STRING(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_STRING
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], *string = NULL;
865
866write_again:
867    switch (OBJECT_TYPE(object)) {
868	case LispNil_t:
869	    if (object == NIL)
870		string = Snil;
871	    else if (object == T)
872		string = St;
873	    else if (object == DOT)
874		string = "#<DOT>";
875	    else if (object == UNSPEC)
876		string = "#<UNSPEC>";
877	    else if (object == UNBOUND)
878		string = "#<UNBOUND>";
879	    else
880		string = "#<ERROR>";
881	    length += LispDoWriteAtom(stream, string, strlen(string),
882				      info->print_case);
883	    break;
884	case LispOpaque_t: {
885	    char *desc = LispIntToOpaqueType(object->data.opaque.type);
886
887	    length += LispWriteChar(stream, '#');
888	    length += LispWriteCPointer(stream, object->data.opaque.data);
889	    length += LispWriteStr(stream, desc, strlen(desc));
890	}   break;
891	case LispAtom_t:
892	    length += LispWriteAtom(stream, object, info);
893	    break;
894	case LispFunction_t:
895	    if (object->data.atom->a_function) {
896		object = object->data.atom->property->fun.function;
897		goto write_lambda;
898	    }
899	    length += LispWriteStr(stream, "#<", 2);
900	    if (object->data.atom->a_compiled)
901		LispDoWriteAtom(stream, "COMPILED", 8, info->print_case);
902	    else if (object->data.atom->a_builtin)
903		LispDoWriteAtom(stream, "BUILTIN", 7, info->print_case);
904	    /* XXX the function does not exist anymore */
905	    /* FIXME not sure if I want this fixed... */
906	    else
907		LispDoWriteAtom(stream, "UNBOUND", 7, info->print_case);
908	    LispDoWriteAtom(stream, "-FUNCTION", 9, info->print_case);
909	    length += LispWriteChar(stream, ' ');
910	    length += LispWriteAtom(stream, object->data.atom->object, info);
911	    length += LispWriteChar(stream, '>');
912	    break;
913	case LispString_t:
914	    length += LispWriteString(stream, object, info);
915	    break;
916	case LispSChar_t:
917	    length += LispWriteCharacter(stream, object, info);
918	    break;
919	case LispDFloat_t:
920	    length += LispWriteFloat(stream, object);
921	    break;
922	case LispFixnum_t:
923	case LispInteger_t:
924	case LispBignum_t:
925	    length += LispWriteInteger(stream, object);
926	    break;
927	case LispRatio_t:
928	    format_integer(stk, object->data.ratio.numerator, 10);
929	    length += LispWriteStr(stream, stk, strlen(stk));
930	    length += LispWriteChar(stream, '/');
931	    format_integer(stk, object->data.ratio.denominator, 10);
932	    length += LispWriteStr(stream, stk, strlen(stk));
933	    break;
934	case LispBigratio_t: {
935	    int sz;
936	    char *ptr;
937
938	    sz = mpi_getsize(mpr_num(object->data.mp.ratio), 10) + 1 +
939		 mpi_getsize(mpr_den(object->data.mp.ratio), 10) + 1 +
940		 (mpi_sgn(mpr_num(object->data.mp.ratio)) < 0);
941	    if (sz > sizeof(stk))
942		ptr = LispMalloc(sz);
943	    else
944		ptr = stk;
945	    mpr_getstr(ptr, object->data.mp.ratio, 10);
946	    length += LispWriteStr(stream, ptr, sz - 1);
947	    if (ptr != stk)
948		LispFree(ptr);
949	}   break;
950	case LispComplex_t:
951	    length += LispWriteStr(stream, "#C(", 3);
952	    length += LispDoWriteObject(stream,
953					object->data.complex.real, info, 0);
954	    length += LispWriteChar(stream, ' ');
955	    length += LispDoWriteObject(stream,
956					object->data.complex.imag, info, 0);
957	    length += LispWriteChar(stream, ')');
958	    break;
959	case LispCons_t:
960	    print_level = info->level;
961	    ++info->level;
962	    length += LispWriteList(stream, object, info, paren);
963	    info->level = print_level;
964	    break;
965	case LispQuote_t:
966	    length += LispWriteChar(stream, '\'');
967	    paren = 1;
968	    object = object->data.quote;
969	    goto write_again;
970	case LispBackquote_t:
971	    length += LispWriteChar(stream, '`');
972	    paren = 1;
973	    object = object->data.quote;
974	    goto write_again;
975	case LispComma_t:
976	    if (object->data.comma.atlist)
977		length += LispWriteStr(stream, ",@", 2);
978	    else
979		length += LispWriteChar(stream, ',');
980	    paren = 1;
981	    object = object->data.comma.eval;
982	    goto write_again;
983	    break;
984	case LispFunctionQuote_t:
985	    length += LispWriteStr(stream, "#'", 2);
986	    paren = 1;
987	    object = object->data.quote;
988	    goto write_again;
989	case LispArray_t:
990	    length += LispWriteArray(stream, object, info);
991	    break;
992	case LispStruct_t:
993	    length += LispWriteStruct(stream, object, info);
994	    break;
995	case LispLambda_t:
996	write_lambda:
997	    switch (object->funtype) {
998		case LispLambda:
999		    string = "#<LAMBDA ";
1000		    break;
1001		case LispFunction:
1002		    string = "#<FUNCTION ";
1003		    break;
1004		case LispMacro:
1005		    string = "#<MACRO ";
1006		    break;
1007		case LispSetf:
1008		    string = "#<SETF ";
1009		    break;
1010	    }
1011	    length += LispDoWriteAtom(stream, string, strlen(string),
1012				      info->print_case);
1013	    if (object->funtype != LispLambda) {
1014		length += LispWriteAtom(stream, object->data.lambda.name, info);
1015		length += LispWriteChar(stream, ' ');
1016		length += LispWriteAlist(stream, object->data.lambda.name
1017					 ->data.atom->property->alist, info);
1018	    }
1019	    else {
1020		length += LispDoWriteAtom(stream, Snil, 3, info->print_case);
1021		length += LispWriteChar(stream, ' ');
1022		length += LispWriteAlist(stream, (LispArgList*)object->
1023					 data.lambda.name->data.opaque.data,
1024					 info);
1025	    }
1026	    length += LispWriteChar(stream, ' ');
1027	    length += LispDoWriteObject(stream,
1028					object->data.lambda.code, info, 0);
1029	    length += LispWriteChar(stream, '>');
1030	    break;
1031	case LispStream_t:
1032	    length += LispWriteStr(stream, "#<", 2);
1033	    if (object->data.stream.type == LispStreamFile)
1034		string = "FILE-STREAM ";
1035	    else if (object->data.stream.type == LispStreamString)
1036		string = "STRING-STREAM ";
1037	    else if (object->data.stream.type == LispStreamStandard)
1038		string = "STANDARD-STREAM ";
1039	    else if (object->data.stream.type == LispStreamPipe)
1040		string = "PIPE-STREAM ";
1041	    length += LispDoWriteAtom(stream, string, strlen(string),
1042				      info->print_case);
1043
1044	    if (!object->data.stream.readable && !object->data.stream.writable)
1045		length += LispDoWriteAtom(stream, "CLOSED",
1046					  6, info->print_case);
1047	    else {
1048		if (object->data.stream.readable)
1049		    length += LispDoWriteAtom(stream, "READ",
1050					      4, info->print_case);
1051		if (object->data.stream.writable) {
1052		    if (object->data.stream.readable)
1053			length += LispWriteChar(stream, '-');
1054		    length += LispDoWriteAtom(stream, "WRITE",
1055					      5, info->print_case);
1056		}
1057	    }
1058	    if (object->data.stream.type != LispStreamString) {
1059		length += LispWriteChar(stream, ' ');
1060		length += LispDoWriteObject(stream,
1061					    object->data.stream.pathname,
1062					    info, 1);
1063		/* same address/size for pipes */
1064		length += LispWriteChar(stream, ' ');
1065		length += LispWriteCPointer(stream,
1066					    object->data.stream.source.file);
1067		if (object->data.stream.readable &&
1068		    object->data.stream.type == LispStreamFile &&
1069		    !object->data.stream.source.file->binary) {
1070		    length += LispWriteStr(stream, " @", 2);
1071		    format_integer(stk, object->data.stream.source.file->line, 10);
1072		    length += LispWriteStr(stream, stk, strlen(stk));
1073		}
1074	    }
1075	    length += LispWriteChar(stream, '>');
1076	    break;
1077	case LispPathname_t:
1078	    length += LispWriteStr(stream, "#P", 2);
1079	    paren = 1;
1080	    object = CAR(object->data.quote);
1081	    goto write_again;
1082	case LispPackage_t:
1083	    length += LispDoWriteAtom(stream, "#<PACKAGE ",
1084				      10, info->print_case);
1085	    length += LispWriteStr(stream,
1086				   THESTR(object->data.package.name),
1087				   STRLEN(object->data.package.name));
1088	    length += LispWriteChar(stream, '>');
1089	    break;
1090	case LispRegex_t:
1091	    length += LispDoWriteAtom(stream, "#<REGEX ",
1092				      8, info->print_case);
1093	    length += LispDoWriteObject(stream,
1094					object->data.regex.pattern, info, 1);
1095	    if (object->data.regex.options & RE_NOSPEC)
1096		length += LispDoWriteAtom(stream, " :NOSPEC",
1097					  8, info->print_case);
1098	    if (object->data.regex.options & RE_ICASE)
1099		length += LispDoWriteAtom(stream, " :ICASE",
1100					  7, info->print_case);
1101	    if (object->data.regex.options & RE_NOSUB)
1102		length += LispDoWriteAtom(stream, " :NOSUB",
1103					  7, info->print_case);
1104	    if (object->data.regex.options & RE_NEWLINE)
1105		length += LispDoWriteAtom(stream, " :NEWLINE",
1106					  9, info->print_case);
1107	    length += LispWriteChar(stream, '>');
1108	    break;
1109	case LispBytecode_t:
1110	    length += LispDoWriteAtom(stream, "#<BYTECODE ",
1111				      11, info->print_case);
1112	    length += LispWriteCPointer(stream,
1113					object->data.bytecode.bytecode);
1114	    length += LispWriteChar(stream, '>');
1115	    break;
1116	case LispHashTable_t:
1117	    length += LispDoWriteAtom(stream, "#<HASH-TABLE ",
1118				      13, info->print_case);
1119	    length += LispWriteAtom(stream, object->data.hash.test, info);
1120	    snprintf(stk, sizeof(stk), " %g %g",
1121		     object->data.hash.table->rehash_size,
1122		     object->data.hash.table->rehash_threshold);
1123	    length += LispWriteStr(stream, stk, strlen(stk));
1124	    snprintf(stk, sizeof(stk), " %ld/%ld>",
1125		     object->data.hash.table->count,
1126		     object->data.hash.table->num_entries);
1127	    length += LispWriteStr(stream, stk, strlen(stk));
1128	    break;
1129    }
1130
1131    return (length);
1132}
1133
1134/* return current column number in stream */
1135int
1136LispGetColumn(LispObj *stream)
1137{
1138    LispFile *file;
1139    LispString *string;
1140
1141    check_stream(stream, &file, &string, 0);
1142    if (file != NULL)
1143	return (file->column);
1144    return (string->column);
1145}
1146
1147/* write a character to stream */
1148int
1149LispWriteChar(LispObj *stream, int character)
1150{
1151    LispFile *file;
1152    LispString *string;
1153
1154    check_stream(stream, &file, &string, 1);
1155    if (file != NULL)
1156	return (LispFputc(file, character));
1157
1158    return (LispSputc(string, character));
1159}
1160
1161/* write a character count times to stream */
1162int
1163LispWriteChars(LispObj *stream, int character, int count)
1164{
1165    int length = 0;
1166
1167    if (count > 0) {
1168	char stk[64];
1169	LispFile *file;
1170	LispString *string;
1171
1172	check_stream(stream, &file, &string, 1);
1173	if (count >= sizeof(stk)) {
1174	    memset(stk, character, sizeof(stk));
1175	    for (; count >= sizeof(stk); count -= sizeof(stk)) {
1176		if (file != NULL)
1177		    length += LispFwrite(file, stk, sizeof(stk));
1178		else
1179		    length += LispSwrite(string, stk, sizeof(stk));
1180	    }
1181	}
1182	else
1183	    memset(stk, character, count);
1184
1185	if (count) {
1186	    if (file != NULL)
1187		length += LispFwrite(file, stk, count);
1188	    else
1189		length += LispSwrite(string, stk, count);
1190	}
1191    }
1192
1193    return (length);
1194}
1195
1196/* write a string to stream */
1197int
1198LispWriteStr(LispObj *stream, char *buffer, long length)
1199{
1200    LispFile *file;
1201    LispString *string;
1202
1203    check_stream(stream, &file, &string, 1);
1204    if (file != NULL)
1205	return (LispFwrite(file, buffer, length));
1206    return (LispSwrite(string, buffer, length));
1207}
1208
1209static int
1210LispDoWriteAtom(LispObj *stream, char *string, int length, int print_case)
1211{
1212    int bytes = 0, cap = 0;
1213    char buffer[128], *ptr;
1214
1215    switch (print_case) {
1216	case DOWNCASE:
1217	    for (ptr = buffer; length > 0; length--, string++) {
1218		if (isupper(*string))
1219		    *ptr = tolower(*string);
1220		else
1221		    *ptr = *string;
1222		++ptr;
1223		if (ptr - buffer >= sizeof(buffer)) {
1224		    bytes += LispWriteStr(stream, buffer, ptr - buffer);
1225		    ptr = buffer;
1226		}
1227	    }
1228	    if (ptr > buffer)
1229		bytes += LispWriteStr(stream, buffer, ptr - buffer);
1230	    break;
1231	case CAPITALIZE:
1232	    for (ptr = buffer; length > 0; length--, string++) {
1233		if (isalnum(*string)) {
1234		    if (cap && isupper(*string))
1235			*ptr = tolower(*string);
1236		    else
1237			*ptr = *string;
1238		    cap = 1;
1239		}
1240		else {
1241		    *ptr = *string;
1242		    cap = 0;
1243		}
1244		++ptr;
1245		if (ptr - buffer >= sizeof(buffer)) {
1246		    bytes += LispWriteStr(stream, buffer, ptr - buffer);
1247		    ptr = buffer;
1248		}
1249	    }
1250	    if (ptr > buffer)
1251		bytes += LispWriteStr(stream, buffer, ptr - buffer);
1252	    break;
1253	default:
1254	    /* Strings are already stored upcase/quoted */
1255	    bytes += LispWriteStr(stream, string, length);
1256	    break;
1257    }
1258
1259    return (bytes);
1260}
1261
1262static int
1263LispWriteAtom(LispObj *stream, LispObj *object, write_info *info)
1264{
1265    int length = 0;
1266    LispAtom *atom = object->data.atom;
1267    Atom_id id = atom->string;
1268
1269    if (atom->package != PACKAGE) {
1270	if (atom->package == lisp__data.keyword)
1271	    length += LispWriteChar(stream, ':');
1272	else if (atom->package == NULL)
1273	    length += LispWriteStr(stream, "#:", 2);
1274	else {
1275	    /* Check if the symbol is visible */
1276	    int i, visible = 0;
1277
1278	    if (atom->ext) {
1279		for (i = lisp__data.pack->use.length - 1; i >= 0; i--) {
1280		    if (lisp__data.pack->use.pairs[i] == atom->package) {
1281			visible = 1;
1282			break;
1283		    }
1284		}
1285	    }
1286
1287	    if (!visible) {
1288		/* XXX this assumes that package names are always "readable" */
1289		length +=
1290		    LispDoWriteAtom(stream,
1291				    THESTR(atom->package->data.package.name),
1292				    STRLEN(atom->package->data.package.name),
1293				    info->print_case);
1294		length += LispWriteChar(stream, ':');
1295		if (!atom->ext)
1296		    length += LispWriteChar(stream, ':');
1297	    }
1298	}
1299    }
1300    if (atom->unreadable)
1301	length += LispWriteChar(stream, '|');
1302    length += LispDoWriteAtom(stream, id, strlen(id),
1303			      atom->unreadable ? UPCASE : info->print_case);
1304    if (atom->unreadable)
1305	length += LispWriteChar(stream, '|');
1306
1307    return (length);
1308}
1309
1310static int
1311LispWriteInteger(LispObj *stream, LispObj *object)
1312{
1313    return (LispFormatInteger(stream, object, 10, 0, 0, 0, 0, 0, 0));
1314}
1315
1316static int
1317LispWriteCharacter(LispObj *stream, LispObj *object, write_info *info)
1318{
1319    return (LispFormatCharacter(stream, object, !info->print_escape, 0));
1320}
1321
1322static int
1323LispWriteString(LispObj *stream, LispObj *object, write_info *info)
1324{
1325    return (LispWriteCString(stream, THESTR(object), STRLEN(object), info));
1326}
1327
1328static int
1329LispWriteFloat(LispObj *stream, LispObj *object)
1330{
1331    double value = DFLOAT_VALUE(object);
1332
1333    if (value == 0.0 || (fabs(value) < 1.0E7 && fabs(value) > 1.0E-4))
1334	return (LispFormatFixedFloat(stream, object, 0, 0, NULL, 0, 0, 0));
1335
1336    return (LispDoFormatExponentialFloat(stream, object, 0, 0, NULL,
1337					 0, 1, 0, ' ', 'E', 0));
1338}
1339
1340static int
1341LispWriteArray(LispObj *stream, LispObj *object, write_info *info)
1342{
1343    int length = 0;
1344    long print_level = info->level, circle;
1345
1346    if (info->circles && (circle = LispCheckCircle(object, info)) >= 0 &&
1347	LispPrintCircle(stream, object, circle, &length, info) == 0)
1348	return (length);
1349
1350    if (object->data.array.rank == 0) {
1351	length += LispWriteStr(stream, "#0A", 3);
1352	length += LispDoWriteObject(stream, object->data.array.list, info, 1);
1353	return (length);
1354    }
1355
1356    INCDEPTH();
1357    ++info->level;
1358    if (info->print_level < 0 || info->level <= info->print_level) {
1359	if (object->data.array.rank == 1)
1360	    length += LispWriteStr(stream, "#(", 2);
1361	else {
1362	    char stk[32];
1363
1364	    format_integer(stk, object->data.array.rank, 10);
1365	    length += LispWriteChar(stream, '#');
1366	    length += LispWriteStr(stream, stk, strlen(stk));
1367	    length += LispWriteStr(stream, "A(", 2);
1368	}
1369
1370	if (!object->data.array.zero) {
1371	    long print_length = info->length, local_length = 0;
1372
1373	    if (object->data.array.rank == 1) {
1374		LispObj *ary;
1375		long count;
1376
1377		for (ary = object->data.array.dim, count = 1;
1378		     ary != NIL; ary = CDR(ary))
1379		    count *= FIXNUM_VALUE(CAR(ary));
1380		for (ary = object->data.array.list; count > 0;
1381		     ary = CDR(ary), count--) {
1382		    if (info->print_length < 0 ||
1383			++local_length <= info->print_length) {
1384			info->length = 0;
1385			length += LispDoWriteObject(stream, CAR(ary), info, 1);
1386		    }
1387		    else {
1388			length += LispWriteStr(stream, "...", 3);
1389			break;
1390		    }
1391		    if (count - 1 > 0)
1392			length += LispWriteChar(stream, ' ');
1393		}
1394	    }
1395	    else {
1396		LispObj *ary;
1397		int i, k, rank, *dims, *loop;
1398
1399		rank = object->data.array.rank;
1400		dims = LispMalloc(sizeof(int) * rank);
1401		loop = LispCalloc(1, sizeof(int) * (rank - 1));
1402
1403		/* fill dim */
1404		for (i = 0, ary = object->data.array.dim; ary != NIL;
1405		     i++, ary = CDR(ary))
1406		    dims[i] = FIXNUM_VALUE(CAR(ary));
1407
1408		i = 0;
1409		ary = object->data.array.list;
1410		while (loop[0] < dims[0]) {
1411		    if (info->print_length < 0 ||
1412			local_length < info->print_length) {
1413			for (; i < rank - 1; i++)
1414			    length += LispWriteChar(stream, '(');
1415			--i;
1416			for (;;) {
1417			    ++loop[i];
1418			    if (i && loop[i] >= dims[i])
1419				loop[i] = 0;
1420			    else
1421				break;
1422			    --i;
1423			}
1424			for (k = 0; k < dims[rank - 1] - 1;
1425			     k++, ary = CDR(ary)) {
1426			    if (info->print_length < 0 ||
1427				k < info->print_length) {
1428				++local_length;
1429				info->length = 0;
1430				length += LispDoWriteObject(stream,
1431							    CAR(ary), info, 1);
1432				length += LispWriteChar(stream, ' ');
1433			    }
1434			}
1435			if (info->print_length < 0 || k < info->print_length) {
1436			    ++local_length;
1437			    info->length = 0;
1438			    length += LispDoWriteObject(stream,
1439							CAR(ary), info, 0);
1440			}
1441			else
1442			    length += LispWriteStr(stream,  "...", 3);
1443			for (k = rank - 1; k > i; k--)
1444			    length += LispWriteChar(stream, ')');
1445			if (loop[0] < dims[0])
1446			    length += LispWriteChar(stream,  ' ');
1447			ary = CDR(ary);
1448		    }
1449		    else {
1450			++local_length;
1451			length += LispWriteStr(stream,	"...)", 4);
1452			for (; local_length < dims[0] - 1; local_length++)
1453			    length += LispWriteStr(stream,  " ...)", 5);
1454			if (local_length <= dims[0])
1455			    length += LispWriteStr(stream,  " ...", 4);
1456			break;
1457		    }
1458		}
1459		LispFree(dims);
1460		LispFree(loop);
1461	    }
1462	    info->length = print_length;
1463	}
1464	length += LispWriteChar(stream, ')');
1465    }
1466    else
1467	length += LispWriteChar(stream, '#');
1468    info->level = print_level;
1469    DECDEPTH();
1470
1471    return (length);
1472}
1473
1474static int
1475LispWriteStruct(LispObj *stream, LispObj *object, write_info *info)
1476{
1477    int length;
1478    long circle;
1479    LispObj *symbol;
1480    LispObj *def = object->data.struc.def;
1481    LispObj *field = object->data.struc.fields;
1482
1483    if (info->circles && (circle = LispCheckCircle(object, info)) >= 0 &&
1484	LispPrintCircle(stream, object, circle, &length, info) == 0)
1485	return (length);
1486
1487    INCDEPTH();
1488    length = LispWriteStr(stream, "#S(", 3);
1489    symbol = SYMBOLP(CAR(def)) ? CAR(def) : CAAR(def);
1490    length += LispWriteAtom(stream, symbol, info);
1491    def = CDR(def);
1492    for (; def != NIL; def = CDR(def), field = CDR(field)) {
1493	length += LispWriteChar(stream, ' ');
1494	symbol = SYMBOLP(CAR(def)) ? CAR(def) : CAAR(def);
1495	length += LispWriteAtom(stream, symbol, info);
1496	length += LispWriteChar(stream, ' ');
1497	length += LispDoWriteObject(stream, CAR(field), info, 1);
1498    }
1499    length += LispWriteChar(stream, ')');
1500    DECDEPTH();
1501
1502    return (length);
1503}
1504
1505int
1506LispFormatInteger(LispObj *stream, LispObj *object, int radix,
1507		  int atsign, int collon, int mincol,
1508		  int padchar, int commachar, int commainterval)
1509{
1510    char stk[128], *str = stk;
1511    int i, length, sign, intervals;
1512
1513    if (LONGINTP(object))
1514	format_integer(stk, LONGINT_VALUE(object), radix);
1515    else {
1516	if (mpi_getsize(object->data.mp.integer, radix) >= sizeof(stk))
1517	    str = mpi_getstr(NULL, object->data.mp.integer, radix);
1518	else
1519	    mpi_getstr(str, object->data.mp.integer, radix);
1520    }
1521
1522    sign = *str == '-';
1523    length = strlen(str);
1524
1525    /* if collon, update length for the number of commachars to be printed */
1526    if (collon && commainterval > 0 && commachar) {
1527	intervals = length / commainterval;
1528	length += intervals;
1529    }
1530    else
1531	intervals = 0;
1532
1533    /* if sign must be printed, and number is positive */
1534    if (atsign && !sign)
1535	++length;
1536
1537    /* if need padding */
1538    if (padchar && mincol > length)
1539	LispWriteChars(stream, padchar, mincol - length);
1540
1541    /* if need to print number sign */
1542    if (sign || atsign)
1543	LispWriteChar(stream, sign ? '-' : '+');
1544
1545    /* if need to print commas to separate groups of numbers */
1546    if (intervals) {
1547	int j;
1548	char *ptr;
1549
1550	i = (length - atsign) - intervals;
1551	j = i % commainterval;
1552	/* make the loop below easier */
1553	if (j == 0)
1554	    j = commainterval;
1555	i -= j;
1556	ptr = str + sign;
1557	for (; j > 0; j--, ptr++)
1558	    LispWriteChar(stream, *ptr);
1559	for (; i > 0; i -= commainterval) {
1560	    LispWriteChar(stream, commachar);
1561	    for (j = 0; j < commainterval; j++, ptr++)
1562		LispWriteChar(stream, *ptr);
1563	}
1564    }
1565    /* else, just print the string */
1566    else
1567	LispWriteStr(stream, str + sign, length - sign);
1568
1569    /* if number required more than sizeof(stk) bytes */
1570    if (str != stk)
1571	LispFree(str);
1572
1573    return (length);
1574}
1575
1576int
1577LispFormatRomanInteger(LispObj *stream, long value, int new_roman)
1578{
1579    char stk[32];
1580    int length;
1581
1582    length = 0;
1583    while (value > 1000) {
1584	stk[length++] = 'M';
1585	value -= 1000;
1586    }
1587    if (new_roman) {
1588	if (value >= 900) {
1589	    strcpy(stk + length, "CM");
1590	    length += 2,
1591	    value -= 900;
1592	}
1593	else if (value < 500 && value >= 400) {
1594	    strcpy(stk + length, "CD");
1595	    length += 2;
1596	    value -= 400;
1597	}
1598    }
1599    if (value >= 500) {
1600	stk[length++] = 'D';
1601	value -= 500;
1602    }
1603    while (value >= 100) {
1604	stk[length++] = 'C';
1605	value -= 100;
1606    }
1607    if (new_roman) {
1608	if (value >= 90) {
1609	    strcpy(stk + length, "XC");
1610	    length += 2,
1611	    value -= 90;
1612	}
1613	else if (value < 50 && value >= 40) {
1614	    strcpy(stk + length, "XL");
1615	    length += 2;
1616	    value -= 40;
1617	}
1618    }
1619    if (value >= 50) {
1620	stk[length++] = 'L';
1621	value -= 50;
1622    }
1623    while (value >= 10) {
1624	stk[length++] = 'X';
1625	value -= 10;
1626    }
1627    if (new_roman) {
1628	if (value == 9) {
1629	    strcpy(stk + length, "IX");
1630	    length += 2,
1631	    value -= 9;
1632	}
1633	else if (value == 4) {
1634	    strcpy(stk + length, "IV");
1635	    length += 2;
1636	    value -= 4;
1637	}
1638    }
1639    if (value >= 5) {
1640	stk[length++] = 'V';
1641	value -= 5;
1642    }
1643    while (value) {
1644	stk[length++] = 'I';
1645	--value;
1646    }
1647
1648    stk[length] = '\0';
1649
1650    return (LispWriteStr(stream, stk, length));
1651}
1652
1653int
1654LispFormatEnglishInteger(LispObj *stream, long number, int ordinal)
1655{
1656    static char *ds[] = {
1657	"",	      "one",	   "two",	 "three",      "four",
1658	"five",       "six",	   "seven",	 "eight",      "nine",
1659	"ten",	      "eleven",    "twelve",	 "thirteen",   "fourteen",
1660	"fifteen",    "sixteen",   "seventeen",  "eighteen",   "nineteen"
1661    };
1662    static char *dsth[] = {
1663	"",	      "first",	   "second",	  "third",	"fourth",
1664	"fifth",      "sixth",	   "seventh",	  "eighth",	"ninth",
1665	"tenth",      "eleventh",  "twelfth",	  "thirteenth", "fourteenth",
1666	 "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth"
1667    };
1668    static char *hs[] = {
1669	"",	      "",	   "twenty",	  "thirty",	"forty",
1670	"fifty",      "sixty",	   "seventy",	  "eighty",	"ninety"
1671    };
1672    static char *hsth[] = {
1673	"",	      "",	   "twentieth",   "thirtieth",	"fortieth",
1674       "fiftieth",    "sixtieth",  "seventieth",  "eightieth",	"ninetieth"
1675    };
1676    static char *ts[] = {
1677	"",	      "thousand",   "million"
1678    };
1679    static char *tsth[] = {
1680	"",	     "thousandth", "millionth"
1681    };
1682    char stk[256];
1683    int length, sign;
1684
1685    sign = number < 0;
1686    if (sign)
1687	number = -number;
1688    length = 0;
1689
1690#define SIGNLEN		6	/* strlen("minus ") */
1691    if (sign) {
1692	strcpy(stk, "minus ");
1693	length += SIGNLEN;
1694    }
1695    else if (number == 0) {
1696	if (ordinal) {
1697	    strcpy(stk, "zeroth");
1698	    length += 6;	/* strlen("zeroth") */
1699	}
1700	else {
1701	    strcpy(stk, "zero");
1702	    length += 4;	/* strlen("zero") */
1703	}
1704    }
1705    for (;;) {
1706	int count, temp;
1707	char *t, *h, *d;
1708	long value = number;
1709
1710	for (count = 0; value >= 1000; value /= 1000, count++)
1711	    ;
1712
1713	t = ds[value / 100];
1714	if (ordinal && !count && (value % 10) == 0)
1715	    h = hsth[(value % 100) / 10];
1716	else
1717	    h = hs[(value % 100) / 10];
1718
1719	if (ordinal && !count)
1720	    d = *h ? dsth[value % 10] : dsth[value % 20];
1721	else
1722	    d = *h ? ds[value % 10] : ds[value % 20];
1723
1724	if (((!sign && length) || length > SIGNLEN) && (*t || *h || *d)) {
1725	    if (!ordinal || count || *h || *t) {
1726		strcpy(stk + length, ", ");
1727		length += 2;
1728	    }
1729	    else {
1730		strcpy(stk + length, " ");
1731		++length;
1732	    }
1733	}
1734
1735	if (*t) {
1736	    if (ordinal && !count && (value % 100) == 0)
1737		temp = sprintf(stk + length, "%s hundredth", t);
1738	    else
1739		temp = sprintf(stk + length, "%s hundred", t);
1740	    length += temp;
1741	}
1742
1743	if (*h) {
1744	    if (*t) {
1745		if (ordinal && !count) {
1746		    strcpy(stk + length, " ");
1747		    ++length;
1748		}
1749		else {
1750		    strcpy(stk + length, " and ");
1751		    length += 5;	/* strlen(" and ") */
1752		}
1753	    }
1754	    strcpy(stk + length, h);
1755	    length += strlen(h);
1756	}
1757
1758	if (*d) {
1759	    if (*h) {
1760		strcpy(stk + length, "-");
1761		++length;
1762	    }
1763	    else if (*t) {
1764		if (ordinal && !count) {
1765		    strcpy(stk + length, " ");
1766		    ++length;
1767		}
1768		else {
1769		    strcpy(stk + length, " and ");
1770		    length += 5;	/* strlen(" and ") */
1771		}
1772	    }
1773	    strcpy(stk + length, d);
1774	    length += strlen(d);
1775	}
1776
1777	if (!count)
1778	    break;
1779	else
1780	    temp = count;
1781
1782	if (count > 1) {
1783	    value *= 1000;
1784	    while (--count)
1785		value *= 1000;
1786	    number -= value;
1787	}
1788	else
1789	    number %= 1000;
1790
1791	if (ordinal && number == 0 && !*t && !*h)
1792	    temp = sprintf(stk + length, " %s", tsth[temp]);
1793	else
1794	    temp = sprintf(stk + length, " %s", ts[temp]);
1795	length += temp;
1796
1797	if (!number)
1798	    break;
1799    }
1800
1801    return (LispWriteStr(stream, stk, length));
1802}
1803
1804int
1805LispFormatCharacter(LispObj *stream, LispObj *object,
1806		    int atsign, int collon)
1807{
1808    int length = 0;
1809    int ch = SCHAR_VALUE(object);
1810
1811    if (atsign && !collon)
1812	length += LispWriteStr(stream, "#\\", 2);
1813    if ((atsign || collon) && (ch <= ' ' || ch == 0177)) {
1814	char *name = LispChars[ch].names[0];
1815
1816	length += LispWriteStr(stream, name, strlen(name));
1817    }
1818    else
1819	length += LispWriteChar(stream, ch);
1820
1821    return (length);
1822}
1823
1824/* returns 1 if string size must grow, done inplace */
1825static int
1826float_string_inc(char *buffer, int offset)
1827{
1828    int i;
1829
1830    for (i = offset; i >= 0; i--) {
1831	if (buffer[i] == '9')
1832	    buffer[i] = '0';
1833	else if (buffer[i] != '.') {
1834	    ++buffer[i];
1835	    break;
1836	}
1837    }
1838    if (i < 0) {
1839	int length = strlen(buffer);
1840
1841	/* string size must change */
1842	memmove(buffer + 1, buffer, length + 1);
1843	buffer[0] = '1';
1844
1845	return (1);
1846    }
1847
1848    return (0);
1849}
1850
1851int
1852LispFormatFixedFloat(LispObj *stream, LispObj *object,
1853		     int atsign, int w, int *pd, int k, int overflowchar,
1854		     int padchar)
1855{
1856    char buffer[512], stk[64];
1857    int sign, exponent, length, offset, d = pd ? *pd : FLOAT_PREC, again;
1858    double value = DFLOAT_VALUE(object);
1859
1860    if (value == 0.0) {
1861	exponent = k = 0;
1862	strcpy(stk, "+0");
1863    }
1864    else
1865	/* calculate format parameters, adjusting scale factor */
1866	parse_double(stk, &exponent, value, d + 1 + k);
1867
1868    /* make sure k won't cause overflow */
1869    if (k > 128)
1870	k = 128;
1871    else if (k < -128)
1872	k = -128;
1873
1874    /* make sure d won't cause overflow */
1875    if (d > 128)
1876	d = 128;
1877    else if (d < -128)
1878	d = -128;
1879
1880    /* adjust scale factor, exponent is used as an index in stk */
1881    exponent += k + 1;
1882
1883    /* how many bytes in float representation */
1884    length = strlen(stk) - 1;
1885
1886    /* need to print a sign? */
1887    sign = atsign || (stk[0] == '-');
1888
1889    /* format number, cannot overflow, as control variables were checked */
1890    offset = 0;
1891    if (sign)
1892	buffer[offset++] = stk[0];
1893    if (exponent > 0) {
1894	if (exponent > length) {
1895	    memcpy(buffer + offset, stk + 1, length);
1896	    memset(buffer + offset + length, '0', exponent - length);
1897	}
1898	else
1899	    memcpy(buffer + offset, stk + 1, exponent);
1900	offset += exponent;
1901	buffer[offset++] = '.';
1902	if (length > exponent) {
1903	    memcpy(buffer + offset, stk + 1 + exponent, length - exponent);
1904	    offset += length - exponent;
1905	}
1906	else
1907	    buffer[offset++] = '0';
1908    }
1909    else {
1910	buffer[offset++] = '0';
1911	buffer[offset++] = '.';
1912	while (exponent < 0) {
1913	    buffer[offset++] = '0';
1914	    exponent++;
1915	}
1916	memcpy(buffer + offset, stk + 1, length);
1917	offset += length;
1918    }
1919    buffer[offset] = '\0';
1920
1921    again = 0;
1922fixed_float_check_again:
1923    /* make sure only d digits are printed after decimal point */
1924    if (d > 0) {
1925	char *dptr = strchr(buffer, '.');
1926
1927	length = strlen(dptr) - 1;
1928	/* check if need to remove excess digits */
1929	if (length > d) {
1930	    int digit;
1931
1932	    offset = (dptr - buffer) + 1 + d;
1933	    digit = buffer[offset];
1934
1935	    /* remove extra digits */
1936	    buffer[offset] = '\0';
1937
1938	    /* check if need to round */
1939	    if (!again && offset > 1 && isdigit(digit) && digit >= '5' &&
1940		isdigit(buffer[offset - 1]) &&
1941		float_string_inc(buffer, offset - 1))
1942		++offset;
1943	}
1944	/* check if need to add extra zero digits to fill space */
1945	else if (length < d) {
1946	    offset += d - length;
1947	    for (++length; length <= d; length++)
1948		dptr[length] = '0';
1949	    dptr[length] = '\0';
1950	}
1951    }
1952    else {
1953	/* no digits after decimal point */
1954	int digit, inc = 0;
1955	char *dptr = strchr(buffer, '.') + 1;
1956
1957	digit = *dptr;
1958	if (!again && digit >= '5' && dptr >= buffer + 2 && isdigit(dptr[-2]))
1959	    inc = float_string_inc(buffer, dptr - buffer - 2);
1960
1961	offset = (dptr - buffer) + inc;
1962	buffer[offset] = '\0';
1963    }
1964
1965    /* if d was not specified, remove any extra zeros */
1966    if (pd == NULL) {
1967	while (offset > 2 && buffer[offset - 2] != '.' &&
1968	       buffer[offset - 1] == '0')
1969	    --offset;
1970	buffer[offset] = '\0';
1971    }
1972
1973    if (w > 0 && offset > w) {
1974	/* first check if can remove extra fractional digits */
1975	if (pd == NULL) {
1976	    char *ptr = strchr(buffer, '.') + 1;
1977
1978	    if (ptr - buffer < w) {
1979		d = w - (ptr - buffer);
1980		goto fixed_float_check_again;
1981	    }
1982	}
1983
1984	/* remove leading "zero" to save space */
1985 	if ((!sign && buffer[0] == '0') || (sign && buffer[1] == '0')) {
1986	    /* ending nul also copied */
1987	    memmove(buffer + sign, buffer + sign + 1, offset);
1988	    --offset;
1989	}
1990	/* remove leading '+' to "save" space */
1991	if (offset > w && buffer[0] == '+') {
1992	    /* ending nul also copied */
1993	    memmove(buffer, buffer + 1, offset);
1994	    --offset;
1995	}
1996    }
1997
1998    /* if cannot represent number in given width */
1999    if (overflowchar && offset > w) {
2000	again = 1;
2001	goto fixed_float_overflow;
2002    }
2003
2004    length = 0;
2005    /* print padding if required */
2006    if (w > offset)
2007	length += LispWriteChars(stream, padchar, w - offset);
2008
2009    /* print float number representation */
2010    return (LispWriteStr(stream, buffer, offset) + length);
2011
2012fixed_float_overflow:
2013    return (LispWriteChars(stream, overflowchar, w));
2014}
2015
2016int
2017LispFormatExponentialFloat(LispObj *stream, LispObj *object,
2018			   int atsign, int w, int *pd, int e, int k,
2019			   int overflowchar, int padchar, int exponentchar)
2020{
2021    return (LispDoFormatExponentialFloat(stream, object, atsign, w,
2022					 pd, e, k, overflowchar, padchar,
2023					 exponentchar, 1));
2024}
2025
2026int
2027LispDoFormatExponentialFloat(LispObj *stream, LispObj *object,
2028			     int atsign, int w, int *pd, int e, int k,
2029			     int overflowchar, int padchar, int exponentchar,
2030			     int format)
2031{
2032    char buffer[512], stk[64];
2033    int sign, exponent, length, offset, d = pd ? *pd : FLOAT_PREC;
2034    double value = DFLOAT_VALUE(object);
2035
2036    if (value == 0.0) {
2037	exponent = 0;
2038	k = 1;
2039	strcpy(stk, "+0");
2040    }
2041    else
2042	/* calculate format parameters, adjusting scale factor */
2043	parse_double(stk, &exponent, value, d + k - 1);
2044
2045    /* set e to a value that won't overflow */
2046    if (e > 16)
2047	e = 16;
2048
2049    /* set k to a value that won't overflow */
2050    if (k > 128)
2051	k = 128;
2052    else if (k < -128)
2053	k = -128;
2054
2055    /* set d to a value that won't overflow */
2056    if (d > 128)
2057	d = 128;
2058    else if (d < -128)
2059	d = -128;
2060
2061    /* how many bytes in float representation */
2062    length = strlen(stk) - 1;
2063
2064    /* need to print a sign? */
2065    sign = atsign || (stk[0] == '-');
2066
2067    /* adjust number of digits after decimal point */
2068    if (k > 0)
2069	d -= k - 1;
2070
2071    /* adjust exponent, based on scale factor */
2072    exponent -= k - 1;
2073
2074    /* format number, cannot overflow, as control variables were checked */
2075    offset = 0;
2076    if (sign)
2077	buffer[offset++] = stk[0];
2078    if (k > 0) {
2079	if (k > length) {
2080	    memcpy(buffer + offset, stk + 1, length);
2081	    offset += length;
2082	}
2083	else {
2084	    memcpy(buffer + offset, stk + 1, k);
2085	    offset += k;
2086	}
2087	buffer[offset++] = '.';
2088	if (length > k) {
2089	    memcpy(buffer + offset, stk + 1 + k, length - k);
2090	    offset += length - k;
2091	}
2092 	else
2093	    buffer[offset++] = '0';
2094    }
2095    else {
2096	int tmp = k;
2097
2098	buffer[offset++] = '0';
2099	buffer[offset++] = '.';
2100	while (tmp < 0) {
2101	    buffer[offset++] = '0';
2102	    tmp++;
2103	}
2104	memcpy(buffer + offset, stk + 1, length);
2105	offset += length;
2106    }
2107
2108    /* if format, then always add a sign to exponent */
2109    buffer[offset++] = exponentchar;
2110    if (format || exponent < 0)
2111	buffer[offset++] = exponent < 0 ? '-' : '+';
2112
2113    /* XXX destroy stk contents */
2114    sprintf(stk, "%%0%dd", e);
2115    /* format scale factor*/
2116    length = sprintf(buffer + offset, stk,
2117		     exponent < 0 ? -exponent : exponent);
2118    /* check for overflow in exponent */
2119    if (length > e && overflowchar)
2120	goto exponential_float_overflow;
2121    offset += length;
2122
2123    /* make sure only d digits are printed after decimal point */
2124    if (d > 0) {
2125	int currd;
2126	char *dptr = strchr(buffer, '.'),
2127	     *eptr = strchr(dptr, exponentchar);
2128
2129	currd = eptr - dptr - 1;
2130	length = strlen(eptr);
2131
2132	/* check if need to remove excess digits */
2133	if (currd > d) {
2134	    int digit, dpos;
2135
2136	    dpos = offset = (dptr - buffer) + 1 + d;
2137	    digit = buffer[offset];
2138
2139	    memmove(buffer + offset, eptr, length + 1);
2140	    /* also copy ending nul character */
2141
2142	    /* adjust offset to length of total string */
2143	    offset += length;
2144
2145	    /* check if need to round */
2146	    if (dpos > 1 && isdigit(digit) && digit >= '5' &&
2147		isdigit(buffer[dpos - 1]) &&
2148		float_string_inc(buffer, dpos - 1))
2149		++offset;
2150	}
2151	/* check if need to add extra zero digits to fill space */
2152	else if (pd && currd < d) {
2153	    memmove(eptr + d - currd, eptr, length + 1);
2154	    /* also copy ending nul character */
2155
2156	    offset += d - currd;
2157	    for (++currd; currd <= d; currd++)
2158		dptr[currd] = '0';
2159	}
2160	/* check if need to remove zeros */
2161	else if (pd == NULL) {
2162	    int zeros = 1;
2163
2164	    while (eptr[-zeros] == '0')
2165		++zeros;
2166	    if (eptr[-zeros] == '.')
2167		--zeros;
2168	    if (zeros > 1) {
2169		memmove(eptr - zeros + 1, eptr, length + 1);
2170		offset -= zeros - 1;
2171	    }
2172	}
2173    }
2174    else {
2175	/* no digits after decimal point */
2176	int digit, inc = 0;
2177	char *dptr = strchr(buffer, '.'),
2178	     *eptr = strchr(dptr, exponentchar);
2179
2180	digit = dptr[1];
2181
2182	offset = (dptr - buffer) + 1;
2183	length = strlen(eptr);
2184	memmove(buffer + offset, eptr, length + 1);
2185	/* also copy ending nul character */
2186
2187 	if (digit >= '5' && dptr >= buffer + 2 &&
2188	    isdigit(dptr[-2]))
2189	    inc = float_string_inc(buffer, dptr - buffer - 2);
2190
2191	/* adjust offset to length of total string */
2192	offset += length + inc;
2193    }
2194
2195    if (w > 0 && offset > w) {
2196	/* remove leading "zero" to save space */
2197	if ((!sign && buffer[0] == '0') || (sign && buffer[1] == '0')) {
2198	    /* ending nul also copied */
2199	    memmove(buffer + sign, buffer + sign + 1, offset);
2200	    --offset;
2201	}
2202	/* remove leading '+' to "save" space */
2203	if (offset > w && buffer[0] == '+') {
2204	    /* ending nul also copied */
2205	    memmove(buffer, buffer + 1, offset);
2206	    --offset;
2207	}
2208    }
2209
2210    /* if cannot represent number in given width */
2211    if (overflowchar && offset > w)
2212	goto exponential_float_overflow;
2213
2214    length = 0;
2215    /* print padding if required */
2216    if (w > offset)
2217	length += LispWriteChars(stream, padchar, w - offset);
2218
2219    /* print float number representation */
2220    return (LispWriteStr(stream, buffer, offset) + length);
2221
2222exponential_float_overflow:
2223    return (LispWriteChars(stream, overflowchar, w));
2224}
2225
2226int
2227LispFormatGeneralFloat(LispObj *stream, LispObj *object,
2228		       int atsign, int w, int *pd, int e, int k,
2229		       int overflowchar, int padchar, int exponentchar)
2230{
2231    char stk[64];
2232    int length, exponent, n, dd, ee, ww, d = pd ? *pd : FLOAT_PREC;
2233    double value = DFLOAT_VALUE(object);
2234
2235    if (value == 0.0) {
2236	exponent = 0;
2237	n = 0;
2238	d = 1;
2239	strcpy(stk, "+0");
2240    }
2241    else {
2242	/* calculate format parameters, adjusting scale factor */
2243	parse_double(stk, &exponent, value, d + k - 1);
2244	n = exponent + 1;
2245    }
2246
2247    /* Let ee equal e+2, or 4 if e is omitted. */
2248    if (e)
2249	ee = e + 2;
2250    else
2251	ee = 4;
2252
2253    /* Let ww equal w-ee, or nil if w is omitted. */
2254    if (w)
2255	ww = w - ee;
2256    else
2257	ww = 0;
2258
2259    dd = d - n;
2260    if (d >= dd && dd >= 0) {
2261	length = LispFormatFixedFloat(stream, object, atsign, ww,
2262				      &dd, 0, overflowchar, padchar);
2263
2264	/* ~ee@T */
2265	length += LispWriteChars(stream, padchar, ee);
2266    }
2267    else
2268	length = LispFormatExponentialFloat(stream, object, atsign,
2269					    w, pd, e, k, overflowchar,
2270					    padchar, exponentchar);
2271
2272    return (length);
2273}
2274
2275int
2276LispFormatDollarFloat(LispObj *stream, LispObj *object,
2277		      int atsign, int collon, int d, int n, int w, int padchar)
2278{
2279    char buffer[512], stk[64];
2280    int sign, exponent, length, offset;
2281    double value = DFLOAT_VALUE(object);
2282
2283    if (value == 0.0) {
2284	exponent = 0;
2285	strcpy(stk, "+0");
2286    }
2287    else
2288	/* calculate format parameters, adjusting scale factor */
2289	parse_double(stk, &exponent, value, d == 0 ? FLOAT_PREC : d + 1);
2290
2291    /* set d to a "sane" value */
2292    if (d > 128)
2293	d = 128;
2294
2295    /* set n to a "sane" value */
2296    if (n > 128)
2297	n = 128;
2298
2299    /* use exponent as index in stk */
2300    ++exponent;
2301
2302    /* don't put sign in buffer,
2303     * if collon specified, must go before padding */
2304    sign = atsign || (stk[0] == '-');
2305
2306    offset = 0;
2307
2308    /* pad with zeros if required */
2309    if (exponent > 0)
2310	n -= exponent;
2311    while (n > 0) {
2312	buffer[offset++] = '0';
2313	n--;
2314    }
2315
2316    /* how many bytes in float representation */
2317    length = strlen(stk) - 1;
2318
2319    if (exponent > 0) {
2320	if (exponent > length) {
2321	    memcpy(buffer + offset, stk + 1, length);
2322	    memset(buffer + offset + length, '0', exponent - length);
2323	}
2324	else
2325	    memcpy(buffer + offset, stk + 1, exponent);
2326	offset += exponent;
2327	buffer[offset++] = '.';
2328	if (length > exponent) {
2329	    memcpy(buffer + offset, stk + 1 + exponent, length - exponent);
2330	    offset += length - exponent;
2331	}
2332	else
2333	    buffer[offset++] = '0';
2334    }
2335    else {
2336	if (n > 0)
2337	    buffer[offset++] = '0';
2338	buffer[offset++] = '.';
2339	while (exponent < 0) {
2340	    buffer[offset++] = '0';
2341	    exponent++;
2342	}
2343	memcpy(buffer + offset, stk + 1, length);
2344	offset += length;
2345    }
2346    buffer[offset] = '\0';
2347
2348    /* make sure only d digits are printed after decimal point */
2349    if (d > 0) {
2350	char *dptr = strchr(buffer, '.');
2351
2352	length = strlen(dptr) - 1;
2353	/* check if need to remove excess digits */
2354	if (length > d) {
2355	    int digit;
2356
2357	    offset = (dptr - buffer) + 1 + d;
2358	    digit = buffer[offset];
2359
2360	    /* remove extra digits */
2361	    buffer[offset] = '\0';
2362
2363	    /* check if need to round */
2364	    if (offset > 1 && isdigit(digit) && digit >= '5' &&
2365		isdigit(buffer[offset - 1]) &&
2366		float_string_inc(buffer, offset - 1))
2367		++offset;
2368	}
2369	/* check if need to add extra zero digits to fill space */
2370	else if (length < d) {
2371	    offset += d - length;
2372	    for (++length; length <= d; length++)
2373		dptr[length] = '0';
2374	    dptr[length] = '\0';
2375	}
2376    }
2377    else {
2378	/* no digits after decimal point */
2379	int digit, inc = 0;
2380	char *dptr = strchr(buffer, '.') + 1;
2381
2382	digit = *dptr;
2383	if (digit >= '5' && dptr >= buffer + 2 && isdigit(dptr[-2]))
2384	    inc = float_string_inc(buffer, dptr - buffer - 2);
2385
2386	offset = (dptr - buffer) + inc;
2387	buffer[offset] = '\0';
2388    }
2389
2390    length = 0;
2391    if (sign) {
2392	++offset;
2393	if (atsign && collon)
2394	    length += LispWriteChar(stream, value >= 0.0 ? '+' : '-');
2395    }
2396
2397    /* print padding if required */
2398    if (w > offset)
2399	length += LispWriteChars(stream, padchar, w - offset);
2400
2401    if (atsign && !collon)
2402	length += LispWriteChar(stream, value >= 0.0 ? '+' : '-');
2403
2404    /* print float number representation */
2405    return (LispWriteStr(stream, buffer, offset) + length);
2406}
2407