summaryrefslogtreecommitdiff
path: root/lisp/write.c
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/write.c')
-rw-r--r--lisp/write.c2411
1 files changed, 2411 insertions, 0 deletions
diff --git a/lisp/write.c b/lisp/write.c
new file mode 100644
index 0000000..4952119
--- /dev/null
+++ b/lisp/write.c
@@ -0,0 +1,2411 @@
+/*
+ * Copyright (c) 2002 by The XFree86 Project, Inc.
+ *
+ * Permission is hereby granted, free of charge, to any person obtaining a
+ * copy of this software and associated documentation files (the "Software"),
+ * to deal in the Software without restriction, including without limitation
+ * the rights to use, copy, modify, merge, publish, distribute, sublicense,
+ * and/or sell copies of the Software, and to permit persons to whom the
+ * Software is furnished to do so, subject to the following conditions:
+ *
+ * The above copyright notice and this permission notice shall be included in
+ * all copies or substantial portions of the Software.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+ * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+ * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
+ * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+ * SOFTWARE.
+ *
+ * Except as contained in this notice, the name of the XFree86 Project shall
+ * not be used in advertising or otherwise to promote the sale, use or other
+ * dealings in this Software without prior written authorization from the
+ * XFree86 Project.
+ *
+ * Author: Paulo César Pereira de Andrade
+ */
+
+/* $XFree86: xc/programs/xedit/lisp/write.c,v 1.30 2002/12/04 18:43:19 paulo Exp $ */
+
+#include "write.h"
+#include "hash.h"
+#include <math.h>
+#include <ctype.h>
+
+#define FLOAT_PREC 17
+
+#define UPCASE 0
+#define DOWNCASE 1
+#define CAPITALIZE 2
+
+#define INCDEPTH() \
+ if (++info->depth > MAX_STACK_DEPTH / 2) \
+ LispDestroy("stack overflow")
+#define DECDEPTH() --info->depth
+
+/*
+ * Types
+ */
+typedef struct _circle_info {
+ long circle_nth; /* nth circular list */
+ LispObj *object; /* the circular object */
+} circle_info;
+
+typedef struct _write_info {
+ long depth;
+ long level; /* current level */
+ long length; /* current length */
+ long print_level; /* *print-level* when started printing */
+ long print_length; /* *print-length* when started printing */
+
+ int print_escape;
+ int print_case;
+
+ long circle_count;
+ /* used while building circle info */
+ LispObj **objects;
+ long num_objects;
+ /* the circular lists */
+ circle_info *circles;
+ long num_circles;
+} write_info;
+
+/*
+ * Prototypes
+ */
+static void check_stream(LispObj*, LispFile**, LispString**, int);
+static void parse_double(char*, int*, double, int);
+static int float_string_inc(char*, int);
+static void format_integer(char*, long, int);
+static int LispWriteCPointer(LispObj*, void*);
+static int LispWriteCString(LispObj*, char*, long, write_info*);
+static int LispDoFormatExponentialFloat(LispObj*, LispObj*,
+ int, int, int*, int, int,
+ int, int, int, int);
+
+static int LispWriteInteger(LispObj*, LispObj*);
+static int LispWriteCharacter(LispObj*, LispObj*, write_info*);
+static int LispWriteString(LispObj*, LispObj*, write_info*);
+static int LispWriteFloat(LispObj*, LispObj*);
+static int LispWriteAtom(LispObj*, LispObj*, write_info*);
+static int LispDoWriteAtom(LispObj*, char*, int, int);
+static int LispWriteList(LispObj*, LispObj*, write_info*, int);
+static int LispWriteArray(LispObj*, LispObj*, write_info*);
+static int LispWriteStruct(LispObj*, LispObj*, write_info*);
+static int LispDoWriteObject(LispObj*, LispObj*, write_info*, int);
+static void LispBuildCircle(LispObj*, write_info*);
+static void LispDoBuildCircle(LispObj*, write_info*);
+static long LispCheckCircle(LispObj*, write_info*);
+static int LispPrintCircle(LispObj*, LispObj*, long, int*, write_info*);
+static int LispWriteAlist(LispObj*, LispArgList*, write_info*);
+
+/*
+ * Initialization
+ */
+LispObj *Oprint_level, *Oprint_length, *Oprint_circle,
+ *Oprint_escape, *Oprint_case;
+LispObj *Kupcase, *Kdowncase, *Kcapitalize;
+
+/*
+ * Implementation
+ */
+void
+LispWriteInit(void)
+{
+ Oprint_level = STATIC_ATOM("*PRINT-LEVEL*");
+ LispProclaimSpecial(Oprint_level, NIL, NIL);
+ LispExportSymbol(Oprint_level);
+
+ Oprint_length = STATIC_ATOM("*PRINT-LENGTH*");
+ LispProclaimSpecial(Oprint_length, NIL, NIL);
+ LispExportSymbol(Oprint_length);
+
+ Oprint_circle = STATIC_ATOM("*PRINT-CIRCLE*");
+ LispProclaimSpecial(Oprint_circle, T, NIL);
+ LispExportSymbol(Oprint_circle);
+
+ Oprint_escape = STATIC_ATOM("*PRINT-ESCAPE*");
+ LispProclaimSpecial(Oprint_escape, T, NIL);
+ LispExportSymbol(Oprint_escape);
+
+ Kupcase = KEYWORD("UPCASE");
+ Kdowncase = KEYWORD("DOWNCASE");
+ Kcapitalize = KEYWORD("CAPITALIZE");
+ Oprint_case = STATIC_ATOM("*PRINT-CASE*");
+ LispProclaimSpecial(Oprint_case, Kupcase, NIL);
+ LispExportSymbol(Oprint_case);
+}
+
+LispObj *
+Lisp_FreshLine(LispBuiltin *builtin)
+/*
+ fresh-line &optional output-stream
+ */
+{
+ LispObj *output_stream;
+
+ output_stream = ARGUMENT(0);
+
+ if (output_stream == UNSPEC)
+ output_stream = NIL;
+ else if (output_stream != NIL) {
+ CHECK_STREAM(output_stream);
+ }
+ if (LispGetColumn(output_stream)) {
+ LispWriteChar(output_stream, '\n');
+ if (output_stream == NIL ||
+ (output_stream->data.stream.type == LispStreamStandard &&
+ output_stream->data.stream.source.file == Stdout))
+ LispFflush(Stdout);
+ return (T);
+ }
+
+ return (NIL);
+}
+
+LispObj *
+Lisp_Prin1(LispBuiltin *builtin)
+/*
+ prin1 object &optional output-stream
+ */
+{
+ LispObj *object, *output_stream;
+
+ output_stream = ARGUMENT(1);
+ object = ARGUMENT(0);
+
+ if (output_stream == UNSPEC)
+ output_stream = NIL;
+ LispPrint(object, output_stream, 0);
+
+ return (object);
+}
+
+LispObj *
+Lisp_Princ(LispBuiltin *builtin)
+/*
+ princ object &optional output-stream
+ */
+{
+ int head;
+ LispObj *object, *output_stream;
+
+ output_stream = ARGUMENT(1);
+ object = ARGUMENT(0);
+
+ if (output_stream == UNSPEC)
+ output_stream = NIL;
+ head = lisp__data.env.length;
+ LispAddVar(Oprint_escape, NIL);
+ ++lisp__data.env.head;
+ LispPrint(object, output_stream, 0);
+ lisp__data.env.head = lisp__data.env.length = head;
+
+ return (object);
+}
+
+LispObj *
+Lisp_Print(LispBuiltin *builtin)
+/*
+ print object &optional output-stream
+ */
+{
+ LispObj *object, *output_stream;
+
+ output_stream = ARGUMENT(1);
+ object = ARGUMENT(0);
+
+ if (output_stream == UNSPEC)
+ output_stream = NIL;
+ LispWriteChar(output_stream, '\n');
+ LispPrint(object, output_stream, 0);
+ LispWriteChar(output_stream, ' ');
+
+ return (object);
+}
+
+LispObj *
+Lisp_Terpri(LispBuiltin *builtin)
+/*
+ terpri &optional output-stream
+ */
+{
+ LispObj *output_stream;
+
+ output_stream = ARGUMENT(0);
+
+ if (output_stream == UNSPEC)
+ output_stream = NIL;
+ else if (output_stream != NIL) {
+ CHECK_STREAM(output_stream);
+ }
+ LispWriteChar(output_stream, '\n');
+ if (output_stream == NIL ||
+ (output_stream->data.stream.type == LispStreamStandard &&
+ output_stream->data.stream.source.file == Stdout))
+ LispFflush(Stdout);
+
+ return (NIL);
+}
+
+LispObj *
+Lisp_Write(LispBuiltin *builtin)
+/*
+ write object &key case circle escape length level lines pretty readably right-margin stream
+ */
+{
+ int head = lisp__data.env.length;
+
+ LispObj *object, *ocase, *circle, *escape, *length, *level,
+ *lines, *pretty, *readably, *right_margin, *stream;
+
+ stream = ARGUMENT(10);
+ right_margin = ARGUMENT(9); /* yet unused */
+ readably = ARGUMENT(8); /* yet unused */
+ pretty = ARGUMENT(7); /* yet unused */
+ lines = ARGUMENT(6); /* yet unused */
+ level = ARGUMENT(5);
+ length = ARGUMENT(4);
+ escape = ARGUMENT(3);
+ circle = ARGUMENT(2);
+ ocase = ARGUMENT(1);
+ object = ARGUMENT(0);
+
+ if (stream == UNSPEC)
+ stream = NIL;
+ else if (stream != NIL) {
+ CHECK_STREAM(stream);
+ }
+
+ /* prepare the printer environment */
+ if (circle != UNSPEC)
+ LispAddVar(Oprint_circle, circle);
+ if (length != UNSPEC)
+ LispAddVar(Oprint_length, length);
+ if (level != UNSPEC)
+ LispAddVar(Oprint_level, level);
+ if (ocase != UNSPEC)
+ LispAddVar(Oprint_case, ocase);
+ if (escape != UNSPEC)
+ LispAddVar(Oprint_escape, escape);
+
+ lisp__data.env.head = lisp__data.env.length;
+
+ (void)LispWriteObject(stream, object);
+
+ lisp__data.env.head = lisp__data.env.length = head;
+
+ return (object);
+}
+
+LispObj *
+Lisp_WriteChar(LispBuiltin *builtin)
+/*
+ write-char character &optional output-stream
+ */
+{
+ int ch;
+
+ LispObj *character, *output_stream;
+
+ output_stream = ARGUMENT(1);
+ character = ARGUMENT(0);
+
+ if (output_stream == UNSPEC)
+ output_stream = NIL;
+ CHECK_SCHAR(character);
+ ch = SCHAR_VALUE(character);
+
+ LispWriteChar(output_stream, ch);
+
+ return (character);
+}
+
+LispObj *
+Lisp_WriteLine(LispBuiltin *builtin)
+/*
+ write-line string &optional output-stream &key start end
+ */
+{
+ return (LispWriteString_(builtin, 1));
+}
+
+LispObj *
+Lisp_WriteString(LispBuiltin *builtin)
+/*
+ write-string string &optional output-stream &key start end
+ */
+{
+ return (LispWriteString_(builtin, 0));
+}
+
+
+int
+LispWriteObject(LispObj *stream, LispObj *object)
+{
+ write_info info;
+ int bytes;
+ LispObj *level, *length, *circle, *oescape, *ocase;
+
+ /* current state */
+ info.depth = info.level = info.length = 0;
+
+ /* maximum level to descend */
+ level = LispGetVar(Oprint_level);
+ if (level && INDEXP(level))
+ info.print_level = FIXNUM_VALUE(level);
+ else
+ info.print_level = -1;
+
+ /* maximum list length */
+ length = LispGetVar(Oprint_length);
+ if (length && INDEXP(length))
+ info.print_length = FIXNUM_VALUE(length);
+ else
+ info.print_length = -1;
+
+ /* detect circular/shared objects? */
+ circle = LispGetVar(Oprint_circle);
+ info.circle_count = 0;
+ info.objects = NULL;
+ info.num_objects = 0;
+ info.circles = NULL;
+ info.num_circles = 0;
+ if (circle && circle != NIL) {
+ LispBuildCircle(object, &info);
+ /* free this data now */
+ if (info.num_objects) {
+ LispFree(info.objects);
+ info.num_objects = 0;
+ }
+ }
+
+ /* escape characters and strings? */
+ oescape = LispGetVar(Oprint_escape);
+ if (oescape != NULL)
+ info.print_escape = oescape == NIL;
+ else
+ info.print_escape = -1;
+
+ /* don't use the default case printing? */
+ ocase = LispGetVar(Oprint_case);
+ if (ocase == Kdowncase)
+ info.print_case = DOWNCASE;
+ else if (ocase == Kcapitalize)
+ info.print_case = CAPITALIZE;
+ else
+ info.print_case = UPCASE;
+
+ bytes = LispDoWriteObject(stream, object, &info, 1);
+ if (circle && circle != NIL && info.num_circles)
+ LispFree(info.circles);
+
+ return (bytes);
+}
+
+static void
+LispBuildCircle(LispObj *object, write_info *info)
+{
+ LispObj *list;
+
+ switch (OBJECT_TYPE(object)) {
+ case LispCons_t:
+ LispDoBuildCircle(object, info);
+ break;
+ case LispArray_t:
+ /* Currently arrays are implemented as lists, but only
+ * the elements could/should be circular */
+ if (LispCheckCircle(object, info) >= 0)
+ return;
+ LispDoBuildCircle(object, info);
+ for (list = object->data.array.list;
+ CONSP(list); list = CDR(list))
+ LispBuildCircle(CAR(list), info);
+ break;
+ case LispStruct_t:
+ /* Like arrays, structs are currently implemented as lists,
+ * but only the elements could/should be circular */
+ if (LispCheckCircle(object, info) >= 0)
+ return;
+ LispDoBuildCircle(object, info);
+ for (list = object->data.struc.fields;
+ CONSP(list); list = CDR(list))
+ LispBuildCircle(CAR(list), info);
+ break;
+ case LispQuote_t:
+ case LispBackquote_t:
+ case LispFunctionQuote_t:
+ LispDoBuildCircle(object, info);
+ LispBuildCircle(object->data.quote, info);
+ break;
+ case LispComma_t:
+ LispDoBuildCircle(object, info);
+ LispBuildCircle(object->data.comma.eval, info);
+ break;
+ case LispLambda_t:
+ /* Circularity in a function body should fail elsewhere... */
+ if (LispCheckCircle(object, info) >= 0)
+ return;
+ LispDoBuildCircle(object, info);
+ LispBuildCircle(object->data.lambda.code, info);
+ break;
+ default:
+ break;
+ }
+}
+
+static void
+LispDoBuildCircle(LispObj *object, write_info *info)
+{
+ long i;
+
+ if (LispCheckCircle(object, info) >= 0)
+ return;
+
+ for (i = 0; i < info->num_objects; i++)
+ if (info->objects[i] == object) {
+ /* circularity found */
+ info->circles = LispRealloc(info->circles, sizeof(circle_info) *
+ (info->num_circles + 1));
+ info->circles[info->num_circles].circle_nth = 0;
+ info->circles[info->num_circles].object = object;
+ ++info->num_circles;
+ return;
+ }
+
+ /* object pointer not yet recorded */
+ if ((i % 16) == 0)
+ info->objects = LispRealloc(info->objects, sizeof(LispObj*) *
+ (info->num_objects + 16));
+ info->objects[info->num_objects++] = object;
+
+ if (CONSP(object)) {
+ if (CONSP(CAR(object)))
+ LispDoBuildCircle(CAR(object), info);
+ else
+ LispBuildCircle(CAR(object), info);
+ if (CONSP(CDR(object)))
+ LispDoBuildCircle(CDR(object), info);
+ else
+ LispBuildCircle(CDR(object), info);
+ }
+}
+
+static long
+LispCheckCircle(LispObj *object, write_info *info)
+{
+ long i;
+
+ for (i = 0; i < info->num_circles; i++)
+ if (info->circles[i].object == object)
+ return (i);
+
+ return (-1);
+}
+
+static int
+LispPrintCircle(LispObj *stream, LispObj *object, long circle,
+ int *length, write_info *info)
+{
+ char stk[32];
+
+ if (!info->circles[circle].circle_nth) {
+ sprintf(stk, "#%ld=", ++info->circle_count);
+ *length += LispWriteStr(stream, stk, strlen(stk));
+ info->circles[circle].circle_nth = info->circle_count;
+
+ return (1);
+ }
+ sprintf(stk, "#%ld#", info->circles[circle].circle_nth);
+ *length += LispWriteStr(stream, stk, strlen(stk));
+
+ return (0);
+}
+
+static int
+LispWriteAlist(LispObj *stream, LispArgList *alist, write_info *info)
+{
+ char *name;
+ int i, length = 0, need_space = 0;
+
+#define WRITE_ATOM(object) \
+ name = ATOMID(object); \
+ length += LispDoWriteAtom(stream, name, strlen(name), \
+ info->print_case)
+#define WRITE_STRING(string) \
+ length += LispDoWriteAtom(stream, string, strlen(string), \
+ info->print_case)
+#define WRITE_OBJECT(object) \
+ length += LispDoWriteObject(stream, object, info, 1)
+#define WRITE_OPAREN() \
+ length += LispWriteChar(stream, '(')
+#define WRITE_SPACE() \
+ length += LispWriteChar(stream, ' ')
+#define WRITE_CPAREN() \
+ length += LispWriteChar(stream, ')')
+
+ WRITE_OPAREN();
+ for (i = 0; i < alist->normals.num_symbols; i++) {
+ WRITE_ATOM(alist->normals.symbols[i]);
+ if (i + 1 < alist->normals.num_symbols)
+ WRITE_SPACE();
+ else
+ need_space = 1;
+ }
+ if (alist->optionals.num_symbols) {
+ if (need_space)
+ WRITE_SPACE();
+ WRITE_STRING(Soptional);
+ WRITE_SPACE();
+ for (i = 0; i < alist->optionals.num_symbols; i++) {
+ WRITE_OPAREN();
+ WRITE_ATOM(alist->optionals.symbols[i]);
+ WRITE_SPACE();
+ WRITE_OBJECT(alist->optionals.defaults[i]);
+ if (alist->optionals.sforms[i]) {
+ WRITE_SPACE();
+ WRITE_ATOM(alist->optionals.sforms[i]);
+ }
+ WRITE_CPAREN();
+ if (i + 1 < alist->optionals.num_symbols)
+ WRITE_SPACE();
+ }
+ need_space = 1;
+ }
+ if (alist->keys.num_symbols) {
+ if (need_space)
+ WRITE_SPACE();
+ length += LispDoWriteAtom(stream, Skey, 4, info->print_case);
+ WRITE_SPACE();
+ for (i = 0; i < alist->keys.num_symbols; i++) {
+ WRITE_OPAREN();
+ if (alist->keys.keys[i]) {
+ WRITE_OPAREN();
+ WRITE_ATOM(alist->keys.keys[i]);
+ WRITE_SPACE();
+ }
+ WRITE_ATOM(alist->keys.symbols[i]);
+ if (alist->keys.keys[i])
+ WRITE_CPAREN();
+ WRITE_SPACE();
+ WRITE_OBJECT(alist->keys.defaults[i]);
+ if (alist->keys.sforms[i]) {
+ WRITE_SPACE();
+ WRITE_ATOM(alist->keys.sforms[i]);
+ }
+ WRITE_CPAREN();
+ if (i + 1 < alist->keys.num_symbols)
+ WRITE_SPACE();
+ }
+ need_space = 1;
+ }
+ if (alist->rest) {
+ if (need_space)
+ WRITE_SPACE();
+ WRITE_STRING(Srest);
+ WRITE_SPACE();
+ WRITE_ATOM(alist->rest);
+ need_space = 1;
+ }
+ if (alist->auxs.num_symbols) {
+ if (need_space)
+ WRITE_SPACE();
+ WRITE_STRING(Saux);
+ WRITE_SPACE();
+ for (i = 0; i < alist->auxs.num_symbols; i++) {
+ WRITE_OPAREN();
+ WRITE_ATOM(alist->auxs.symbols[i]);
+ WRITE_SPACE();
+ WRITE_OBJECT(alist->auxs.initials[i]);
+ WRITE_CPAREN();
+ if (i + 1 < alist->auxs.num_symbols)
+ WRITE_SPACE();
+ }
+ }
+ WRITE_CPAREN();
+
+#undef WRITE_ATOM
+#undef WRITE_STRING
+#undef WRITE_OBJECT
+#undef WRITE_OPAREN
+#undef WRITE_SPACE
+#undef WRITE_CPAREN
+
+ return (length);
+}
+
+static void
+check_stream(LispObj *stream,
+ LispFile **file, LispString **string, int check_writable)
+{
+ /* NIL is UNIX stdout, *STANDARD-OUTPUT* may not be UNIX stdout */
+ if (stream == NIL) {
+ *file = Stdout;
+ *string = NULL;
+ }
+ else {
+ if (!STREAMP(stream))
+ LispDestroy("%s is not a stream", STROBJ(stream));
+ if (check_writable && !stream->data.stream.writable)
+ LispDestroy("%s is not writable", STROBJ(stream));
+ else if (stream->data.stream.type == LispStreamString) {
+ *string = SSTREAMP(stream);
+ *file = NULL;
+ }
+ else {
+ if (stream->data.stream.type == LispStreamPipe)
+ *file = OPSTREAMP(stream);
+ else
+ *file = stream->data.stream.source.file;
+ *string = NULL;
+ }
+ }
+}
+
+/* Assumes buffer has enough storage, 64 bytes should be more than enough */
+static void
+parse_double(char *buffer, int *exponent, double value, int d)
+{
+ char stk[64], fmt[32], *ptr, *fract = NULL;
+ int positive = value >= 0.0;
+
+parse_double_again:
+ if (d >= 8) {
+ double dcheck;
+ int icheck, count;
+
+ /* this should to do the correct rounding */
+ for (count = 2; count >= 0; count--) {
+ icheck = d <= 0 ? 0 : d > FLOAT_PREC ? FLOAT_PREC - count : d - count;
+ sprintf(fmt, "%%.%de", icheck);
+ sprintf(stk, fmt, value);
+ if (count) {
+ /* if the value read back is the same formatted */
+ sscanf(stk, "%lf", &dcheck);
+ if (dcheck == value)
+ break;
+ }
+ }
+ }
+ else {
+ sprintf(fmt, "%%.%de", d <= 0 ? 0 : d > FLOAT_PREC ? FLOAT_PREC : d);
+ sprintf(stk, fmt, value);
+ }
+
+ /* this "should" never fail */
+ ptr = strchr(stk, 'e');
+ if (ptr) {
+ *ptr++ = '\0';
+ *exponent = atoi(ptr);
+ }
+ else
+ *exponent = 0;
+
+ /* find start of number representation */
+ for (ptr = stk; *ptr && !isdigit(*ptr); ptr++)
+ ;
+
+ /* check if did not trim any significant digit,
+ * this may happen because '%.e' puts only one digit before the '.' */
+ if (d > 0 && d < FLOAT_PREC && fabs(value) >= 10.0 &&
+ strlen(ptr) - 1 - !positive <= *exponent) {
+ d += *exponent - (strlen(ptr) - 1 - !positive) + 1;
+ goto parse_double_again;
+ }
+
+ /* this "should" never fail */
+ fract = strchr(ptr, '.');
+ if (fract)
+ *fract++ = '\0';
+
+ /* store number representation in buffer */
+ *buffer = positive ? '+' : '-';
+ strcpy(buffer + 1, ptr);
+ if (fract)
+ strcpy(buffer + strlen(buffer), fract);
+}
+
+static void
+format_integer(char *buffer, long value, int radix)
+{
+ if (radix == 10)
+ sprintf(buffer, "%ld", value);
+ else if (radix == 16)
+ sprintf(buffer, "%lx", value);
+ else if (radix == 8)
+ sprintf(buffer, "%lo", value);
+ else {
+ /* use bignum routine to convert number to string */
+ mpi integer;
+
+ mpi_init(&integer);
+ mpi_seti(&integer, value);
+ mpi_getstr(buffer, &integer, radix);
+ mpi_clear(&integer);
+ }
+}
+
+static int
+LispWriteCPointer(LispObj *stream, void *data)
+{
+ char stk[32];
+
+#ifdef LONG64
+ sprintf(stk, "0x%016lx", (long)data);
+#else
+ sprintf(stk, "0x%08lx", (long)data);
+#endif
+
+ return (LispWriteStr(stream, stk, strlen(stk)));
+}
+
+static int
+LispWriteCString(LispObj *stream, char *string, long length, write_info *info)
+{
+ int result;
+
+ if (!info->print_escape) {
+ char *base, *ptr, *end;
+
+ result = LispWriteChar(stream, '"');
+ for (base = ptr = string, end = string + length; ptr < end; ptr++) {
+ if (*ptr == '\\' || *ptr == '"') {
+ result += LispWriteStr(stream, base, ptr - base);
+ result += LispWriteChar(stream, '\\');
+ result += LispWriteChar(stream, *ptr);
+ base = ptr + 1;
+ }
+ }
+ result += LispWriteStr(stream, base, end - base);
+ result += LispWriteChar(stream, '"');
+ }
+ else
+ result = LispWriteStr(stream, string, length);
+
+ return (result);
+}
+
+static int
+LispWriteList(LispObj *stream, LispObj *object, write_info *info, int paren)
+{
+ int length = 0;
+ long circle = 0;
+
+ INCDEPTH();
+ if (info->print_level < 0 || info->level <= info->print_level) {
+ LispObj *car, *cdr;
+ long print_length = info->length;
+
+ if (info->circles && (circle = LispCheckCircle(object, info)) >= 0) {
+ if (!paren) {
+ length += LispWriteStr(stream, ". ", 2);
+ paren = 1;
+ }
+ if (LispPrintCircle(stream, object, circle, &length, info) == 0) {
+ DECDEPTH();
+
+ return (length);
+ }
+ }
+
+ car = CAR(object);
+ cdr = CDR(object);
+
+ if (cdr == NIL) {
+ if (paren)
+ length += LispWriteChar(stream, '(');
+ if (info->print_length < 0 || info->length < info->print_length) {
+ info->length = 0;
+ length += LispDoWriteObject(stream, car, info, 1);
+ info->length = print_length + 1;
+ }
+ else
+ length += LispWriteStr(stream, "...", 3);
+ if (paren)
+ length += LispWriteChar(stream, ')');
+ }
+ else {
+ if (paren)
+ length += LispWriteChar(stream, '(');
+ if (info->print_length < 0 || info->length < info->print_length) {
+ info->length = 0;
+ length += LispDoWriteObject(stream, car, info, 1);
+ info->length = print_length + 1;
+ if (!CONSP(cdr)) {
+ length += LispWriteStr(stream, " . ", 3);
+ info->length = 0;
+ length += LispDoWriteObject(stream, cdr, info, 0);
+ }
+ else {
+ length += LispWriteChar(stream, ' ');
+ if (info->print_length < 0 ||
+ info->length < info->print_length)
+ length += LispWriteList(stream, cdr, info, 0);
+ else
+ length += LispWriteStr(stream, "...", 3);
+ }
+ }
+ else
+ length += LispWriteStr(stream, "...", 3);
+ if (paren)
+ length += LispWriteChar(stream, ')');
+ }
+ info->length = print_length;
+ }
+ else
+ length += LispWriteChar(stream, '#');
+ DECDEPTH();
+
+ return (length);
+}
+
+static int
+LispDoWriteObject(LispObj *stream, LispObj *object, write_info *info, int paren)
+{
+ long print_level;
+ int length = 0;
+ char stk[64], *string = NULL;
+
+write_again:
+ switch (OBJECT_TYPE(object)) {
+ case LispNil_t:
+ if (object == NIL)
+ string = Snil;
+ else if (object == T)
+ string = St;
+ else if (object == DOT)
+ string = "#<DOT>";
+ else if (object == UNSPEC)
+ string = "#<UNSPEC>";
+ else if (object == UNBOUND)
+ string = "#<UNBOUND>";
+ else
+ string = "#<ERROR>";
+ length += LispDoWriteAtom(stream, string, strlen(string),
+ info->print_case);
+ break;
+ case LispOpaque_t: {
+ char *desc = LispIntToOpaqueType(object->data.opaque.type);
+
+ length += LispWriteChar(stream, '#');
+ length += LispWriteCPointer(stream, object->data.opaque.data);
+ length += LispWriteStr(stream, desc, strlen(desc));
+ } break;
+ case LispAtom_t:
+ length += LispWriteAtom(stream, object, info);
+ break;
+ case LispFunction_t:
+ if (object->data.atom->a_function) {
+ object = object->data.atom->property->fun.function;
+ goto write_lambda;
+ }
+ length += LispWriteStr(stream, "#<", 2);
+ if (object->data.atom->a_compiled)
+ LispDoWriteAtom(stream, "COMPILED", 8, info->print_case);
+ else if (object->data.atom->a_builtin)
+ LispDoWriteAtom(stream, "BUILTIN", 7, info->print_case);
+ /* XXX the function does not exist anymore */
+ /* FIXME not sure if I want this fixed... */
+ else
+ LispDoWriteAtom(stream, "UNBOUND", 7, info->print_case);
+ LispDoWriteAtom(stream, "-FUNCTION", 9, info->print_case);
+ length += LispWriteChar(stream, ' ');
+ length += LispWriteAtom(stream, object->data.atom->object, info);
+ length += LispWriteChar(stream, '>');
+ break;
+ case LispString_t:
+ length += LispWriteString(stream, object, info);
+ break;
+ case LispSChar_t:
+ length += LispWriteCharacter(stream, object, info);
+ break;
+ case LispDFloat_t:
+ length += LispWriteFloat(stream, object);
+ break;
+ case LispFixnum_t:
+ case LispInteger_t:
+ case LispBignum_t:
+ length += LispWriteInteger(stream, object);
+ break;
+ case LispRatio_t:
+ format_integer(stk, object->data.ratio.numerator, 10);
+ length += LispWriteStr(stream, stk, strlen(stk));
+ length += LispWriteChar(stream, '/');
+ format_integer(stk, object->data.ratio.denominator, 10);
+ length += LispWriteStr(stream, stk, strlen(stk));
+ break;
+ case LispBigratio_t: {
+ int sz;
+ char *ptr;
+
+ sz = mpi_getsize(mpr_num(object->data.mp.ratio), 10) + 1 +
+ mpi_getsize(mpr_den(object->data.mp.ratio), 10) + 1 +
+ (mpi_sgn(mpr_num(object->data.mp.ratio)) < 0);
+ if (sz > sizeof(stk))
+ ptr = LispMalloc(sz);
+ else
+ ptr = stk;
+ mpr_getstr(ptr, object->data.mp.ratio, 10);
+ length += LispWriteStr(stream, ptr, sz - 1);
+ if (ptr != stk)
+ LispFree(ptr);
+ } break;
+ case LispComplex_t:
+ length += LispWriteStr(stream, "#C(", 3);
+ length += LispDoWriteObject(stream,
+ object->data.complex.real, info, 0);
+ length += LispWriteChar(stream, ' ');
+ length += LispDoWriteObject(stream,
+ object->data.complex.imag, info, 0);
+ length += LispWriteChar(stream, ')');
+ break;
+ case LispCons_t:
+ print_level = info->level;
+ ++info->level;
+ length += LispWriteList(stream, object, info, paren);
+ info->level = print_level;
+ break;
+ case LispQuote_t:
+ length += LispWriteChar(stream, '\'');
+ paren = 1;
+ object = object->data.quote;
+ goto write_again;
+ case LispBackquote_t:
+ length += LispWriteChar(stream, '`');
+ paren = 1;
+ object = object->data.quote;
+ goto write_again;
+ case LispComma_t:
+ if (object->data.comma.atlist)
+ length += LispWriteStr(stream, ",@", 2);
+ else
+ length += LispWriteChar(stream, ',');
+ paren = 1;
+ object = object->data.comma.eval;
+ goto write_again;
+ break;
+ case LispFunctionQuote_t:
+ length += LispWriteStr(stream, "#'", 2);
+ paren = 1;
+ object = object->data.quote;
+ goto write_again;
+ case LispArray_t:
+ length += LispWriteArray(stream, object, info);
+ break;
+ case LispStruct_t:
+ length += LispWriteStruct(stream, object, info);
+ break;
+ case LispLambda_t:
+ write_lambda:
+ switch (object->funtype) {
+ case LispLambda:
+ string = "#<LAMBDA ";
+ break;
+ case LispFunction:
+ string = "#<FUNCTION ";
+ break;
+ case LispMacro:
+ string = "#<MACRO ";
+ break;
+ case LispSetf:
+ string = "#<SETF ";
+ break;
+ }
+ length += LispDoWriteAtom(stream, string, strlen(string),
+ info->print_case);
+ if (object->funtype != LispLambda) {
+ length += LispWriteAtom(stream, object->data.lambda.name, info);
+ length += LispWriteChar(stream, ' ');
+ length += LispWriteAlist(stream, object->data.lambda.name
+ ->data.atom->property->alist, info);
+ }
+ else {
+ length += LispDoWriteAtom(stream, Snil, 3, info->print_case);
+ length += LispWriteChar(stream, ' ');
+ length += LispWriteAlist(stream, (LispArgList*)object->
+ data.lambda.name->data.opaque.data,
+ info);
+ }
+ length += LispWriteChar(stream, ' ');
+ length += LispDoWriteObject(stream,
+ object->data.lambda.code, info, 0);
+ length += LispWriteChar(stream, '>');
+ break;
+ case LispStream_t:
+ length += LispWriteStr(stream, "#<", 2);
+ if (object->data.stream.type == LispStreamFile)
+ string = "FILE-STREAM ";
+ else if (object->data.stream.type == LispStreamString)
+ string = "STRING-STREAM ";
+ else if (object->data.stream.type == LispStreamStandard)
+ string = "STANDARD-STREAM ";
+ else if (object->data.stream.type == LispStreamPipe)
+ string = "PIPE-STREAM ";
+ length += LispDoWriteAtom(stream, string, strlen(string),
+ info->print_case);
+
+ if (!object->data.stream.readable && !object->data.stream.writable)
+ length += LispDoWriteAtom(stream, "CLOSED",
+ 6, info->print_case);
+ else {
+ if (object->data.stream.readable)
+ length += LispDoWriteAtom(stream, "READ",
+ 4, info->print_case);
+ if (object->data.stream.writable) {
+ if (object->data.stream.readable)
+ length += LispWriteChar(stream, '-');
+ length += LispDoWriteAtom(stream, "WRITE",
+ 5, info->print_case);
+ }
+ }
+ if (object->data.stream.type != LispStreamString) {
+ length += LispWriteChar(stream, ' ');
+ length += LispDoWriteObject(stream,
+ object->data.stream.pathname,
+ info, 1);
+ /* same address/size for pipes */
+ length += LispWriteChar(stream, ' ');
+ length += LispWriteCPointer(stream,
+ object->data.stream.source.file);
+ if (object->data.stream.readable &&
+ object->data.stream.type == LispStreamFile &&
+ !object->data.stream.source.file->binary) {
+ length += LispWriteStr(stream, " @", 2);
+ format_integer(stk, object->data.stream.source.file->line, 10);
+ length += LispWriteStr(stream, stk, strlen(stk));
+ }
+ }
+ length += LispWriteChar(stream, '>');
+ break;
+ case LispPathname_t:
+ length += LispWriteStr(stream, "#P", 2);
+ paren = 1;
+ object = CAR(object->data.quote);
+ goto write_again;
+ case LispPackage_t:
+ length += LispDoWriteAtom(stream, "#<PACKAGE ",
+ 10, info->print_case);
+ length += LispWriteStr(stream,
+ THESTR(object->data.package.name),
+ STRLEN(object->data.package.name));
+ length += LispWriteChar(stream, '>');
+ break;
+ case LispRegex_t:
+ length += LispDoWriteAtom(stream, "#<REGEX ",
+ 8, info->print_case);
+ length += LispDoWriteObject(stream,
+ object->data.regex.pattern, info, 1);
+ if (object->data.regex.options & RE_NOSPEC)
+ length += LispDoWriteAtom(stream, " :NOSPEC",
+ 8, info->print_case);
+ if (object->data.regex.options & RE_ICASE)
+ length += LispDoWriteAtom(stream, " :ICASE",
+ 7, info->print_case);
+ if (object->data.regex.options & RE_NOSUB)
+ length += LispDoWriteAtom(stream, " :NOSUB",
+ 7, info->print_case);
+ if (object->data.regex.options & RE_NEWLINE)
+ length += LispDoWriteAtom(stream, " :NEWLINE",
+ 9, info->print_case);
+ length += LispWriteChar(stream, '>');
+ break;
+ case LispBytecode_t:
+ length += LispDoWriteAtom(stream, "#<BYTECODE ",
+ 11, info->print_case);
+ length += LispWriteCPointer(stream,
+ object->data.bytecode.bytecode);
+ length += LispWriteChar(stream, '>');
+ break;
+ case LispHashTable_t:
+ length += LispDoWriteAtom(stream, "#<HASH-TABLE ",
+ 13, info->print_case);
+ length += LispWriteAtom(stream, object->data.hash.test, info);
+ snprintf(stk, sizeof(stk), " %g %g",
+ object->data.hash.table->rehash_size,
+ object->data.hash.table->rehash_threshold);
+ length += LispWriteStr(stream, stk, strlen(stk));
+ snprintf(stk, sizeof(stk), " %ld/%ld>",
+ object->data.hash.table->count,
+ object->data.hash.table->num_entries);
+ length += LispWriteStr(stream, stk, strlen(stk));
+ break;
+ }
+
+ return (length);
+}
+
+/* return current column number in stream */
+int
+LispGetColumn(LispObj *stream)
+{
+ LispFile *file;
+ LispString *string;
+
+ check_stream(stream, &file, &string, 0);
+ if (file != NULL)
+ return (file->column);
+ return (string->column);
+}
+
+/* write a character to stream */
+int
+LispWriteChar(LispObj *stream, int character)
+{
+ LispFile *file;
+ LispString *string;
+
+ check_stream(stream, &file, &string, 1);
+ if (file != NULL)
+ return (LispFputc(file, character));
+
+ return (LispSputc(string, character));
+}
+
+/* write a character count times to stream */
+int
+LispWriteChars(LispObj *stream, int character, int count)
+{
+ int length = 0;
+
+ if (count > 0) {
+ char stk[64];
+ LispFile *file;
+ LispString *string;
+
+ check_stream(stream, &file, &string, 1);
+ if (count >= sizeof(stk)) {
+ memset(stk, character, sizeof(stk));
+ for (; count >= sizeof(stk); count -= sizeof(stk)) {
+ if (file != NULL)
+ length += LispFwrite(file, stk, sizeof(stk));
+ else
+ length += LispSwrite(string, stk, sizeof(stk));
+ }
+ }
+ else
+ memset(stk, character, count);
+
+ if (count) {
+ if (file != NULL)
+ length += LispFwrite(file, stk, count);
+ else
+ length += LispSwrite(string, stk, count);
+ }
+ }
+
+ return (length);
+}
+
+/* write a string to stream */
+int
+LispWriteStr(LispObj *stream, char *buffer, long length)
+{
+ LispFile *file;
+ LispString *string;
+
+ check_stream(stream, &file, &string, 1);
+ if (file != NULL)
+ return (LispFwrite(file, buffer, length));
+ return (LispSwrite(string, buffer, length));
+}
+
+static int
+LispDoWriteAtom(LispObj *stream, char *string, int length, int print_case)
+{
+ int bytes = 0, cap = 0;
+ char buffer[128], *ptr;
+
+ switch (print_case) {
+ case DOWNCASE:
+ for (ptr = buffer; length > 0; length--, string++) {
+ if (isupper(*string))
+ *ptr = tolower(*string);
+ else
+ *ptr = *string;
+ ++ptr;
+ if (ptr - buffer >= sizeof(buffer)) {
+ bytes += LispWriteStr(stream, buffer, ptr - buffer);
+ ptr = buffer;
+ }
+ }
+ if (ptr > buffer)
+ bytes += LispWriteStr(stream, buffer, ptr - buffer);
+ break;
+ case CAPITALIZE:
+ for (ptr = buffer; length > 0; length--, string++) {
+ if (isalnum(*string)) {
+ if (cap && isupper(*string))
+ *ptr = tolower(*string);
+ else
+ *ptr = *string;
+ cap = 1;
+ }
+ else {
+ *ptr = *string;
+ cap = 0;
+ }
+ ++ptr;
+ if (ptr - buffer >= sizeof(buffer)) {
+ bytes += LispWriteStr(stream, buffer, ptr - buffer);
+ ptr = buffer;
+ }
+ }
+ if (ptr > buffer)
+ bytes += LispWriteStr(stream, buffer, ptr - buffer);
+ break;
+ default:
+ /* Strings are already stored upcase/quoted */
+ bytes += LispWriteStr(stream, string, length);
+ break;
+ }
+
+ return (bytes);
+}
+
+static int
+LispWriteAtom(LispObj *stream, LispObj *object, write_info *info)
+{
+ int length = 0;
+ LispAtom *atom = object->data.atom;
+ Atom_id id = atom->string;
+
+ if (atom->package != PACKAGE) {
+ if (atom->package == lisp__data.keyword)
+ length += LispWriteChar(stream, ':');
+ else if (atom->package == NULL)
+ length += LispWriteStr(stream, "#:", 2);
+ else {
+ /* Check if the symbol is visible */
+ int i, visible = 0;
+
+ if (atom->ext) {
+ for (i = lisp__data.pack->use.length - 1; i >= 0; i--) {
+ if (lisp__data.pack->use.pairs[i] == atom->package) {
+ visible = 1;
+ break;
+ }
+ }
+ }
+
+ if (!visible) {
+ /* XXX this assumes that package names are always "readable" */
+ length +=
+ LispDoWriteAtom(stream,
+ THESTR(atom->package->data.package.name),
+ STRLEN(atom->package->data.package.name),
+ info->print_case);
+ length += LispWriteChar(stream, ':');
+ if (!atom->ext)
+ length += LispWriteChar(stream, ':');
+ }
+ }
+ }
+ if (atom->unreadable)
+ length += LispWriteChar(stream, '|');
+ length += LispDoWriteAtom(stream, id, strlen(id),
+ atom->unreadable ? UPCASE : info->print_case);
+ if (atom->unreadable)
+ length += LispWriteChar(stream, '|');
+
+ return (length);
+}
+
+static int
+LispWriteInteger(LispObj *stream, LispObj *object)
+{
+ return (LispFormatInteger(stream, object, 10, 0, 0, 0, 0, 0, 0));
+}
+
+static int
+LispWriteCharacter(LispObj *stream, LispObj *object, write_info *info)
+{
+ return (LispFormatCharacter(stream, object, !info->print_escape, 0));
+}
+
+static int
+LispWriteString(LispObj *stream, LispObj *object, write_info *info)
+{
+ return (LispWriteCString(stream, THESTR(object), STRLEN(object), info));
+}
+
+static int
+LispWriteFloat(LispObj *stream, LispObj *object)
+{
+ double value = DFLOAT_VALUE(object);
+
+ if (value == 0.0 || (fabs(value) < 1.0E7 && fabs(value) > 1.0E-4))
+ return (LispFormatFixedFloat(stream, object, 0, 0, NULL, 0, 0, 0));
+
+ return (LispDoFormatExponentialFloat(stream, object, 0, 0, NULL,
+ 0, 1, 0, ' ', 'E', 0));
+}
+
+static int
+LispWriteArray(LispObj *stream, LispObj *object, write_info *info)
+{
+ int length = 0;
+ long print_level = info->level, circle;
+
+ if (info->circles && (circle = LispCheckCircle(object, info)) >= 0 &&
+ LispPrintCircle(stream, object, circle, &length, info) == 0)
+ return (length);
+
+ if (object->data.array.rank == 0) {
+ length += LispWriteStr(stream, "#0A", 3);
+ length += LispDoWriteObject(stream, object->data.array.list, info, 1);
+ return (length);
+ }
+
+ INCDEPTH();
+ ++info->level;
+ if (info->print_level < 0 || info->level <= info->print_level) {
+ if (object->data.array.rank == 1)
+ length += LispWriteStr(stream, "#(", 2);
+ else {
+ char stk[32];
+
+ format_integer(stk, object->data.array.rank, 10);
+ length += LispWriteChar(stream, '#');
+ length += LispWriteStr(stream, stk, strlen(stk));
+ length += LispWriteStr(stream, "A(", 2);
+ }
+
+ if (!object->data.array.zero) {
+ long print_length = info->length, local_length = 0;
+
+ if (object->data.array.rank == 1) {
+ LispObj *ary;
+ long count;
+
+ for (ary = object->data.array.dim, count = 1;
+ ary != NIL; ary = CDR(ary))
+ count *= FIXNUM_VALUE(CAR(ary));
+ for (ary = object->data.array.list; count > 0;
+ ary = CDR(ary), count--) {
+ if (info->print_length < 0 ||
+ ++local_length <= info->print_length) {
+ info->length = 0;
+ length += LispDoWriteObject(stream, CAR(ary), info, 1);
+ }
+ else {
+ length += LispWriteStr(stream, "...", 3);
+ break;
+ }
+ if (count - 1 > 0)
+ length += LispWriteChar(stream, ' ');
+ }
+ }
+ else {
+ LispObj *ary;
+ int i, k, rank, *dims, *loop;
+
+ rank = object->data.array.rank;
+ dims = LispMalloc(sizeof(int) * rank);
+ loop = LispCalloc(1, sizeof(int) * (rank - 1));
+
+ /* fill dim */
+ for (i = 0, ary = object->data.array.dim; ary != NIL;
+ i++, ary = CDR(ary))
+ dims[i] = FIXNUM_VALUE(CAR(ary));
+
+ i = 0;
+ ary = object->data.array.list;
+ while (loop[0] < dims[0]) {
+ if (info->print_length < 0 ||
+ local_length < info->print_length) {
+ for (; i < rank - 1; i++)
+ length += LispWriteChar(stream, '(');
+ --i;
+ for (;;) {
+ ++loop[i];
+ if (i && loop[i] >= dims[i])
+ loop[i] = 0;
+ else
+ break;
+ --i;
+ }
+ for (k = 0; k < dims[rank - 1] - 1;
+ k++, ary = CDR(ary)) {
+ if (info->print_length < 0 ||
+ k < info->print_length) {
+ ++local_length;
+ info->length = 0;
+ length += LispDoWriteObject(stream,
+ CAR(ary), info, 1);
+ length += LispWriteChar(stream, ' ');
+ }
+ }
+ if (info->print_length < 0 || k < info->print_length) {
+ ++local_length;
+ info->length = 0;
+ length += LispDoWriteObject(stream,
+ CAR(ary), info, 0);
+ }
+ else
+ length += LispWriteStr(stream, "...", 3);
+ for (k = rank - 1; k > i; k--)
+ length += LispWriteChar(stream, ')');
+ if (loop[0] < dims[0])
+ length += LispWriteChar(stream, ' ');
+ ary = CDR(ary);
+ }
+ else {
+ ++local_length;
+ length += LispWriteStr(stream, "...)", 4);
+ for (; local_length < dims[0] - 1; local_length++)
+ length += LispWriteStr(stream, " ...)", 5);
+ if (local_length <= dims[0])
+ length += LispWriteStr(stream, " ...", 4);
+ break;
+ }
+ }
+ LispFree(dims);
+ LispFree(loop);
+ }
+ info->length = print_length;
+ }
+ length += LispWriteChar(stream, ')');
+ }
+ else
+ length += LispWriteChar(stream, '#');
+ info->level = print_level;
+ DECDEPTH();
+
+ return (length);
+}
+
+static int
+LispWriteStruct(LispObj *stream, LispObj *object, write_info *info)
+{
+ int length;
+ long circle;
+ LispObj *symbol;
+ LispObj *def = object->data.struc.def;
+ LispObj *field = object->data.struc.fields;
+
+ if (info->circles && (circle = LispCheckCircle(object, info)) >= 0 &&
+ LispPrintCircle(stream, object, circle, &length, info) == 0)
+ return (length);
+
+ INCDEPTH();
+ length = LispWriteStr(stream, "#S(", 3);
+ symbol = SYMBOLP(CAR(def)) ? CAR(def) : CAAR(def);
+ length += LispWriteAtom(stream, symbol, info);
+ def = CDR(def);
+ for (; def != NIL; def = CDR(def), field = CDR(field)) {
+ length += LispWriteChar(stream, ' ');
+ symbol = SYMBOLP(CAR(def)) ? CAR(def) : CAAR(def);
+ length += LispWriteAtom(stream, symbol, info);
+ length += LispWriteChar(stream, ' ');
+ length += LispDoWriteObject(stream, CAR(field), info, 1);
+ }
+ length += LispWriteChar(stream, ')');
+ DECDEPTH();
+
+ return (length);
+}
+
+int
+LispFormatInteger(LispObj *stream, LispObj *object, int radix,
+ int atsign, int collon, int mincol,
+ int padchar, int commachar, int commainterval)
+{
+ char stk[128], *str = stk;
+ int i, length, sign, intervals;
+
+ if (LONGINTP(object))
+ format_integer(stk, LONGINT_VALUE(object), radix);
+ else {
+ if (mpi_getsize(object->data.mp.integer, radix) >= sizeof(stk))
+ str = mpi_getstr(NULL, object->data.mp.integer, radix);
+ else
+ mpi_getstr(str, object->data.mp.integer, radix);
+ }
+
+ sign = *str == '-';
+ length = strlen(str);
+
+ /* if collon, update length for the number of commachars to be printed */
+ if (collon && commainterval > 0 && commachar) {
+ intervals = length / commainterval;
+ length += intervals;
+ }
+ else
+ intervals = 0;
+
+ /* if sign must be printed, and number is positive */
+ if (atsign && !sign)
+ ++length;
+
+ /* if need padding */
+ if (padchar && mincol > length)
+ LispWriteChars(stream, padchar, mincol - length);
+
+ /* if need to print number sign */
+ if (sign || atsign)
+ LispWriteChar(stream, sign ? '-' : '+');
+
+ /* if need to print commas to separate groups of numbers */
+ if (intervals) {
+ int j;
+ char *ptr;
+
+ i = (length - atsign) - intervals;
+ j = i % commainterval;
+ /* make the loop below easier */
+ if (j == 0)
+ j = commainterval;
+ i -= j;
+ ptr = str + sign;
+ for (; j > 0; j--, ptr++)
+ LispWriteChar(stream, *ptr);
+ for (; i > 0; i -= commainterval) {
+ LispWriteChar(stream, commachar);
+ for (j = 0; j < commainterval; j++, ptr++)
+ LispWriteChar(stream, *ptr);
+ }
+ }
+ /* else, just print the string */
+ else
+ LispWriteStr(stream, str + sign, length - sign);
+
+ /* if number required more than sizeof(stk) bytes */
+ if (str != stk)
+ LispFree(str);
+
+ return (length);
+}
+
+int
+LispFormatRomanInteger(LispObj *stream, long value, int new_roman)
+{
+ char stk[32];
+ int length;
+
+ length = 0;
+ while (value > 1000) {
+ stk[length++] = 'M';
+ value -= 1000;
+ }
+ if (new_roman) {
+ if (value >= 900) {
+ strcpy(stk + length, "CM");
+ length += 2,
+ value -= 900;
+ }
+ else if (value < 500 && value >= 400) {
+ strcpy(stk + length, "CD");
+ length += 2;
+ value -= 400;
+ }
+ }
+ if (value >= 500) {
+ stk[length++] = 'D';
+ value -= 500;
+ }
+ while (value >= 100) {
+ stk[length++] = 'C';
+ value -= 100;
+ }
+ if (new_roman) {
+ if (value >= 90) {
+ strcpy(stk + length, "XC");
+ length += 2,
+ value -= 90;
+ }
+ else if (value < 50 && value >= 40) {
+ strcpy(stk + length, "XL");
+ length += 2;
+ value -= 40;
+ }
+ }
+ if (value >= 50) {
+ stk[length++] = 'L';
+ value -= 50;
+ }
+ while (value >= 10) {
+ stk[length++] = 'X';
+ value -= 10;
+ }
+ if (new_roman) {
+ if (value == 9) {
+ strcpy(stk + length, "IX");
+ length += 2,
+ value -= 9;
+ }
+ else if (value == 4) {
+ strcpy(stk + length, "IV");
+ length += 2;
+ value -= 4;
+ }
+ }
+ if (value >= 5) {
+ stk[length++] = 'V';
+ value -= 5;
+ }
+ while (value) {
+ stk[length++] = 'I';
+ --value;
+ }
+
+ stk[length] = '\0';
+
+ return (LispWriteStr(stream, stk, length));
+}
+
+int
+LispFormatEnglishInteger(LispObj *stream, long number, int ordinal)
+{
+ static char *ds[] = {
+ "", "one", "two", "three", "four",
+ "five", "six", "seven", "eight", "nine",
+ "ten", "eleven", "twelve", "thirteen", "fourteen",
+ "fifteen", "sixteen", "seventeen", "eighteen", "nineteen"
+ };
+ static char *dsth[] = {
+ "", "first", "second", "third", "fourth",
+ "fifth", "sixth", "seventh", "eighth", "ninth",
+ "tenth", "eleventh", "twelfth", "thirteenth", "fourteenth",
+ "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth"
+ };
+ static char *hs[] = {
+ "", "", "twenty", "thirty", "forty",
+ "fifty", "sixty", "seventy", "eighty", "ninety"
+ };
+ static char *hsth[] = {
+ "", "", "twentieth", "thirtieth", "fortieth",
+ "fiftieth", "sixtieth", "seventieth", "eightieth", "ninetieth"
+ };
+ static char *ts[] = {
+ "", "thousand", "million"
+ };
+ static char *tsth[] = {
+ "", "thousandth", "millionth"
+ };
+ char stk[256];
+ int length, sign;
+
+ sign = number < 0;
+ if (sign)
+ number = -number;
+ length = 0;
+
+#define SIGNLEN 6 /* strlen("minus ") */
+ if (sign) {
+ strcpy(stk, "minus ");
+ length += SIGNLEN;
+ }
+ else if (number == 0) {
+ if (ordinal) {
+ strcpy(stk, "zeroth");
+ length += 6; /* strlen("zeroth") */
+ }
+ else {
+ strcpy(stk, "zero");
+ length += 4; /* strlen("zero") */
+ }
+ }
+ for (;;) {
+ int count, temp;
+ char *t, *h, *d;
+ long value = number;
+
+ for (count = 0; value >= 1000; value /= 1000, count++)
+ ;
+
+ t = ds[value / 100];
+ if (ordinal && !count && (value % 10) == 0)
+ h = hsth[(value % 100) / 10];
+ else
+ h = hs[(value % 100) / 10];
+
+ if (ordinal && !count)
+ d = *h ? dsth[value % 10] : dsth[value % 20];
+ else
+ d = *h ? ds[value % 10] : ds[value % 20];
+
+ if (((!sign && length) || length > SIGNLEN) && (*t || *h || *d)) {
+ if (!ordinal || count || *h || *t) {
+ strcpy(stk + length, ", ");
+ length += 2;
+ }
+ else {
+ strcpy(stk + length, " ");
+ ++length;
+ }
+ }
+
+ if (*t) {
+ if (ordinal && !count && (value % 100) == 0)
+ temp = sprintf(stk + length, "%s hundredth", t);
+ else
+ temp = sprintf(stk + length, "%s hundred", t);
+ length += temp;
+ }
+
+ if (*h) {
+ if (*t) {
+ if (ordinal && !count) {
+ strcpy(stk + length, " ");
+ ++length;
+ }
+ else {
+ strcpy(stk + length, " and ");
+ length += 5; /* strlen(" and ") */
+ }
+ }
+ strcpy(stk + length, h);
+ length += strlen(h);
+ }
+
+ if (*d) {
+ if (*h) {
+ strcpy(stk + length, "-");
+ ++length;
+ }
+ else if (*t) {
+ if (ordinal && !count) {
+ strcpy(stk + length, " ");
+ ++length;
+ }
+ else {
+ strcpy(stk + length, " and ");
+ length += 5; /* strlen(" and ") */
+ }
+ }
+ strcpy(stk + length, d);
+ length += strlen(d);
+ }
+
+ if (!count)
+ break;
+ else
+ temp = count;
+
+ if (count > 1) {
+ value *= 1000;
+ while (--count)
+ value *= 1000;
+ number -= value;
+ }
+ else
+ number %= 1000;
+
+ if (ordinal && number == 0 && !*t && !*h)
+ temp = sprintf(stk + length, " %s", tsth[temp]);
+ else
+ temp = sprintf(stk + length, " %s", ts[temp]);
+ length += temp;
+
+ if (!number)
+ break;
+ }
+
+ return (LispWriteStr(stream, stk, length));
+}
+
+int
+LispFormatCharacter(LispObj *stream, LispObj *object,
+ int atsign, int collon)
+{
+ int length = 0;
+ int ch = SCHAR_VALUE(object);
+
+ if (atsign && !collon)
+ length += LispWriteStr(stream, "#\\", 2);
+ if ((atsign || collon) && (ch <= ' ' || ch == 0177)) {
+ char *name = LispChars[ch].names[0];
+
+ length += LispWriteStr(stream, name, strlen(name));
+ }
+ else
+ length += LispWriteChar(stream, ch);
+
+ return (length);
+}
+
+/* returns 1 if string size must grow, done inplace */
+static int
+float_string_inc(char *buffer, int offset)
+{
+ int i;
+
+ for (i = offset; i >= 0; i--) {
+ if (buffer[i] == '9')
+ buffer[i] = '0';
+ else if (buffer[i] != '.') {
+ ++buffer[i];
+ break;
+ }
+ }
+ if (i < 0) {
+ int length = strlen(buffer);
+
+ /* string size must change */
+ memmove(buffer + 1, buffer, length + 1);
+ buffer[0] = '1';
+
+ return (1);
+ }
+
+ return (0);
+}
+
+int
+LispFormatFixedFloat(LispObj *stream, LispObj *object,
+ int atsign, int w, int *pd, int k, int overflowchar,
+ int padchar)
+{
+ char buffer[512], stk[64];
+ int sign, exponent, length, offset, d = pd ? *pd : FLOAT_PREC, again;
+ double value = DFLOAT_VALUE(object);
+
+ if (value == 0.0) {
+ exponent = k = 0;
+ strcpy(stk, "+0");
+ }
+ else
+ /* calculate format parameters, adjusting scale factor */
+ parse_double(stk, &exponent, value, d + 1 + k);
+
+ /* make sure k won't cause overflow */
+ if (k > 128)
+ k = 128;
+ else if (k < -128)
+ k = -128;
+
+ /* make sure d won't cause overflow */
+ if (d > 128)
+ d = 128;
+ else if (d < -128)
+ d = -128;
+
+ /* adjust scale factor, exponent is used as an index in stk */
+ exponent += k + 1;
+
+ /* how many bytes in float representation */
+ length = strlen(stk) - 1;
+
+ /* need to print a sign? */
+ sign = atsign || (stk[0] == '-');
+
+ /* format number, cannot overflow, as control variables were checked */
+ offset = 0;
+ if (sign)
+ buffer[offset++] = stk[0];
+ if (exponent > 0) {
+ if (exponent > length) {
+ memcpy(buffer + offset, stk + 1, length);
+ memset(buffer + offset + length, '0', exponent - length);
+ }
+ else
+ memcpy(buffer + offset, stk + 1, exponent);
+ offset += exponent;
+ buffer[offset++] = '.';
+ if (length > exponent) {
+ memcpy(buffer + offset, stk + 1 + exponent, length - exponent);
+ offset += length - exponent;
+ }
+ else
+ buffer[offset++] = '0';
+ }
+ else {
+ buffer[offset++] = '0';
+ buffer[offset++] = '.';
+ while (exponent < 0) {
+ buffer[offset++] = '0';
+ exponent++;
+ }
+ memcpy(buffer + offset, stk + 1, length);
+ offset += length;
+ }
+ buffer[offset] = '\0';
+
+ again = 0;
+fixed_float_check_again:
+ /* make sure only d digits are printed after decimal point */
+ if (d > 0) {
+ char *dptr = strchr(buffer, '.');
+
+ length = strlen(dptr) - 1;
+ /* check if need to remove excess digits */
+ if (length > d) {
+ int digit;
+
+ offset = (dptr - buffer) + 1 + d;
+ digit = buffer[offset];
+
+ /* remove extra digits */
+ buffer[offset] = '\0';
+
+ /* check if need to round */
+ if (!again && offset > 1 && isdigit(digit) && digit >= '5' &&
+ isdigit(buffer[offset - 1]) &&
+ float_string_inc(buffer, offset - 1))
+ ++offset;
+ }
+ /* check if need to add extra zero digits to fill space */
+ else if (length < d) {
+ offset += d - length;
+ for (++length; length <= d; length++)
+ dptr[length] = '0';
+ dptr[length] = '\0';
+ }
+ }
+ else {
+ /* no digits after decimal point */
+ int digit, inc = 0;
+ char *dptr = strchr(buffer, '.') + 1;
+
+ digit = *dptr;
+ if (!again && digit >= '5' && dptr >= buffer + 2 && isdigit(dptr[-2]))
+ inc = float_string_inc(buffer, dptr - buffer - 2);
+
+ offset = (dptr - buffer) + inc;
+ buffer[offset] = '\0';
+ }
+
+ /* if d was not specified, remove any extra zeros */
+ if (pd == NULL) {
+ while (offset > 2 && buffer[offset - 2] != '.' &&
+ buffer[offset - 1] == '0')
+ --offset;
+ buffer[offset] = '\0';
+ }
+
+ if (w > 0 && offset > w) {
+ /* first check if can remove extra fractional digits */
+ if (pd == NULL) {
+ char *ptr = strchr(buffer, '.') + 1;
+
+ if (ptr - buffer < w) {
+ d = w - (ptr - buffer);
+ goto fixed_float_check_again;
+ }
+ }
+
+ /* remove leading "zero" to save space */
+ if ((!sign && buffer[0] == '0') || (sign && buffer[1] == '0')) {
+ /* ending nul also copied */
+ memmove(buffer + sign, buffer + sign + 1, offset);
+ --offset;
+ }
+ /* remove leading '+' to "save" space */
+ if (offset > w && buffer[0] == '+') {
+ /* ending nul also copied */
+ memmove(buffer, buffer + 1, offset);
+ --offset;
+ }
+ }
+
+ /* if cannot represent number in given width */
+ if (overflowchar && offset > w) {
+ again = 1;
+ goto fixed_float_overflow;
+ }
+
+ length = 0;
+ /* print padding if required */
+ if (w > offset)
+ length += LispWriteChars(stream, padchar, w - offset);
+
+ /* print float number representation */
+ return (LispWriteStr(stream, buffer, offset) + length);
+
+fixed_float_overflow:
+ return (LispWriteChars(stream, overflowchar, w));
+}
+
+int
+LispFormatExponentialFloat(LispObj *stream, LispObj *object,
+ int atsign, int w, int *pd, int e, int k,
+ int overflowchar, int padchar, int exponentchar)
+{
+ return (LispDoFormatExponentialFloat(stream, object, atsign, w,
+ pd, e, k, overflowchar, padchar,
+ exponentchar, 1));
+}
+
+int
+LispDoFormatExponentialFloat(LispObj *stream, LispObj *object,
+ int atsign, int w, int *pd, int e, int k,
+ int overflowchar, int padchar, int exponentchar,
+ int format)
+{
+ char buffer[512], stk[64];
+ int sign, exponent, length, offset, d = pd ? *pd : FLOAT_PREC;
+ double value = DFLOAT_VALUE(object);
+
+ if (value == 0.0) {
+ exponent = 0;
+ k = 1;
+ strcpy(stk, "+0");
+ }
+ else
+ /* calculate format parameters, adjusting scale factor */
+ parse_double(stk, &exponent, value, d + k - 1);
+
+ /* set e to a value that won't overflow */
+ if (e > 16)
+ e = 16;
+
+ /* set k to a value that won't overflow */
+ if (k > 128)
+ k = 128;
+ else if (k < -128)
+ k = -128;
+
+ /* set d to a value that won't overflow */
+ if (d > 128)
+ d = 128;
+ else if (d < -128)
+ d = -128;
+
+ /* how many bytes in float representation */
+ length = strlen(stk) - 1;
+
+ /* need to print a sign? */
+ sign = atsign || (stk[0] == '-');
+
+ /* adjust number of digits after decimal point */
+ if (k > 0)
+ d -= k - 1;
+
+ /* adjust exponent, based on scale factor */
+ exponent -= k - 1;
+
+ /* format number, cannot overflow, as control variables were checked */
+ offset = 0;
+ if (sign)
+ buffer[offset++] = stk[0];
+ if (k > 0) {
+ if (k > length) {
+ memcpy(buffer + offset, stk + 1, length);
+ offset += length;
+ }
+ else {
+ memcpy(buffer + offset, stk + 1, k);
+ offset += k;
+ }
+ buffer[offset++] = '.';
+ if (length > k) {
+ memcpy(buffer + offset, stk + 1 + k, length - k);
+ offset += length - k;
+ }
+ else
+ buffer[offset++] = '0';
+ }
+ else {
+ int tmp = k;
+
+ buffer[offset++] = '0';
+ buffer[offset++] = '.';
+ while (tmp < 0) {
+ buffer[offset++] = '0';
+ tmp++;
+ }
+ memcpy(buffer + offset, stk + 1, length);
+ offset += length;
+ }
+
+ /* if format, then always add a sign to exponent */
+ buffer[offset++] = exponentchar;
+ if (format || exponent < 0)
+ buffer[offset++] = exponent < 0 ? '-' : '+';
+
+ /* XXX destroy stk contents */
+ sprintf(stk, "%%0%dd", e);
+ /* format scale factor*/
+ length = sprintf(buffer + offset, stk,
+ exponent < 0 ? -exponent : exponent);
+ /* check for overflow in exponent */
+ if (length > e && overflowchar)
+ goto exponential_float_overflow;
+ offset += length;
+
+ /* make sure only d digits are printed after decimal point */
+ if (d > 0) {
+ int currd;
+ char *dptr = strchr(buffer, '.'),
+ *eptr = strchr(dptr, exponentchar);
+
+ currd = eptr - dptr - 1;
+ length = strlen(eptr);
+
+ /* check if need to remove excess digits */
+ if (currd > d) {
+ int digit, dpos;
+
+ dpos = offset = (dptr - buffer) + 1 + d;
+ digit = buffer[offset];
+
+ memmove(buffer + offset, eptr, length + 1);
+ /* also copy ending nul character */
+
+ /* adjust offset to length of total string */
+ offset += length;
+
+ /* check if need to round */
+ if (dpos > 1 && isdigit(digit) && digit >= '5' &&
+ isdigit(buffer[dpos - 1]) &&
+ float_string_inc(buffer, dpos - 1))
+ ++offset;
+ }
+ /* check if need to add extra zero digits to fill space */
+ else if (pd && currd < d) {
+ memmove(eptr + d - currd, eptr, length + 1);
+ /* also copy ending nul character */
+
+ offset += d - currd;
+ for (++currd; currd <= d; currd++)
+ dptr[currd] = '0';
+ }
+ /* check if need to remove zeros */
+ else if (pd == NULL) {
+ int zeros = 1;
+
+ while (eptr[-zeros] == '0')
+ ++zeros;
+ if (eptr[-zeros] == '.')
+ --zeros;
+ if (zeros > 1) {
+ memmove(eptr - zeros + 1, eptr, length + 1);
+ offset -= zeros - 1;
+ }
+ }
+ }
+ else {
+ /* no digits after decimal point */
+ int digit, inc = 0;
+ char *dptr = strchr(buffer, '.'),
+ *eptr = strchr(dptr, exponentchar);
+
+ digit = dptr[1];
+
+ offset = (dptr - buffer) + 1;
+ length = strlen(eptr);
+ memmove(buffer + offset, eptr, length + 1);
+ /* also copy ending nul character */
+
+ if (digit >= '5' && dptr >= buffer + 2 &&
+ isdigit(dptr[-2]))
+ inc = float_string_inc(buffer, dptr - buffer - 2);
+
+ /* adjust offset to length of total string */
+ offset += length + inc;
+ }
+
+ if (w > 0 && offset > w) {
+ /* remove leading "zero" to save space */
+ if ((!sign && buffer[0] == '0') || (sign && buffer[1] == '0')) {
+ /* ending nul also copied */
+ memmove(buffer + sign, buffer + sign + 1, offset);
+ --offset;
+ }
+ /* remove leading '+' to "save" space */
+ if (offset > w && buffer[0] == '+') {
+ /* ending nul also copied */
+ memmove(buffer, buffer + 1, offset);
+ --offset;
+ }
+ }
+
+ /* if cannot represent number in given width */
+ if (overflowchar && offset > w)
+ goto exponential_float_overflow;
+
+ length = 0;
+ /* print padding if required */
+ if (w > offset)
+ length += LispWriteChars(stream, padchar, w - offset);
+
+ /* print float number representation */
+ return (LispWriteStr(stream, buffer, offset) + length);
+
+exponential_float_overflow:
+ return (LispWriteChars(stream, overflowchar, w));
+}
+
+int
+LispFormatGeneralFloat(LispObj *stream, LispObj *object,
+ int atsign, int w, int *pd, int e, int k,
+ int overflowchar, int padchar, int exponentchar)
+{
+ char stk[64];
+ int length, exponent, n, dd, ee, ww, d = pd ? *pd : FLOAT_PREC;
+ double value = DFLOAT_VALUE(object);
+
+ if (value == 0.0) {
+ exponent = 0;
+ n = 0;
+ d = 1;
+ strcpy(stk, "+0");
+ }
+ else {
+ /* calculate format parameters, adjusting scale factor */
+ parse_double(stk, &exponent, value, d + k - 1);
+ n = exponent + 1;
+ }
+
+ /* Let ee equal e+2, or 4 if e is omitted. */
+ if (e)
+ ee = e + 2;
+ else
+ ee = 4;
+
+ /* Let ww equal w-ee, or nil if w is omitted. */
+ if (w)
+ ww = w - ee;
+ else
+ ww = 0;
+
+ dd = d - n;
+ if (d >= dd && dd >= 0) {
+ length = LispFormatFixedFloat(stream, object, atsign, ww,
+ &dd, 0, overflowchar, padchar);
+
+ /* ~ee@T */
+ length += LispWriteChars(stream, padchar, ee);
+ }
+ else
+ length = LispFormatExponentialFloat(stream, object, atsign,
+ w, pd, e, k, overflowchar,
+ padchar, exponentchar);
+
+ return (length);
+}
+
+int
+LispFormatDollarFloat(LispObj *stream, LispObj *object,
+ int atsign, int collon, int d, int n, int w, int padchar)
+{
+ char buffer[512], stk[64];
+ int sign, exponent, length, offset;
+ double value = DFLOAT_VALUE(object);
+
+ if (value == 0.0) {
+ exponent = 0;
+ strcpy(stk, "+0");
+ }
+ else
+ /* calculate format parameters, adjusting scale factor */
+ parse_double(stk, &exponent, value, d == 0 ? FLOAT_PREC : d + 1);
+
+ /* set d to a "sane" value */
+ if (d > 128)
+ d = 128;
+
+ /* set n to a "sane" value */
+ if (n > 128)
+ n = 128;
+
+ /* use exponent as index in stk */
+ ++exponent;
+
+ /* don't put sign in buffer,
+ * if collon specified, must go before padding */
+ sign = atsign || (stk[0] == '-');
+
+ offset = 0;
+
+ /* pad with zeros if required */
+ if (exponent > 0)
+ n -= exponent;
+ while (n > 0) {
+ buffer[offset++] = '0';
+ n--;
+ }
+
+ /* how many bytes in float representation */
+ length = strlen(stk) - 1;
+
+ if (exponent > 0) {
+ if (exponent > length) {
+ memcpy(buffer + offset, stk + 1, length);
+ memset(buffer + offset + length, '0', exponent - length);
+ }
+ else
+ memcpy(buffer + offset, stk + 1, exponent);
+ offset += exponent;
+ buffer[offset++] = '.';
+ if (length > exponent) {
+ memcpy(buffer + offset, stk + 1 + exponent, length - exponent);
+ offset += length - exponent;
+ }
+ else
+ buffer[offset++] = '0';
+ }
+ else {
+ if (n > 0)
+ buffer[offset++] = '0';
+ buffer[offset++] = '.';
+ while (exponent < 0) {
+ buffer[offset++] = '0';
+ exponent++;
+ }
+ memcpy(buffer + offset, stk + 1, length);
+ offset += length;
+ }
+ buffer[offset] = '\0';
+
+ /* make sure only d digits are printed after decimal point */
+ if (d > 0) {
+ char *dptr = strchr(buffer, '.');
+
+ length = strlen(dptr) - 1;
+ /* check if need to remove excess digits */
+ if (length > d) {
+ int digit;
+
+ offset = (dptr - buffer) + 1 + d;
+ digit = buffer[offset];
+
+ /* remove extra digits */
+ buffer[offset] = '\0';
+
+ /* check if need to round */
+ if (offset > 1 && isdigit(digit) && digit >= '5' &&
+ isdigit(buffer[offset - 1]) &&
+ float_string_inc(buffer, offset - 1))
+ ++offset;
+ }
+ /* check if need to add extra zero digits to fill space */
+ else if (length < d) {
+ offset += d - length;
+ for (++length; length <= d; length++)
+ dptr[length] = '0';
+ dptr[length] = '\0';
+ }
+ }
+ else {
+ /* no digits after decimal point */
+ int digit, inc = 0;
+ char *dptr = strchr(buffer, '.') + 1;
+
+ digit = *dptr;
+ if (digit >= '5' && dptr >= buffer + 2 && isdigit(dptr[-2]))
+ inc = float_string_inc(buffer, dptr - buffer - 2);
+
+ offset = (dptr - buffer) + inc;
+ buffer[offset] = '\0';
+ }
+
+ length = 0;
+ if (sign) {
+ ++offset;
+ if (atsign && collon)
+ length += LispWriteChar(stream, value >= 0.0 ? '+' : '-');
+ }
+
+ /* print padding if required */
+ if (w > offset)
+ length += LispWriteChars(stream, padchar, w - offset);
+
+ if (atsign && !collon)
+ length += LispWriteChar(stream, value >= 0.0 ? '+' : '-');
+
+ /* print float number representation */
+ return (LispWriteStr(stream, buffer, offset) + length);
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 09:58:23 +0000