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/read.c,v 1.36tsi Exp $ */
31
32#include <errno.h>
33#include "lisp/read.h"
34#include "lisp/package.h"
35#include "lisp/write.h"
36#include <fcntl.h>
37#include <stdarg.h>
38
39/* This should be visible only in read.c, but if an error is generated,
40 * the current code in write.c will print it as #<ERROR> */
41#define LABEL_BIT_COUNT		8
42#define LABEL_BIT_MASK		0xff
43#define MAX_LABEL_VALUE		((1L << (sizeof(long) * 8 - 9)) - 1)
44#define READLABEL(label)						\
45    (LispObj*)(((label) << LABEL_BIT_COUNT) | READLABEL_MASK)
46#define READLABELP(object)						\
47    (((unsigned long)(object) & LABEL_BIT_MASK) == READLABEL_MASK)
48#define READLABEL_VALUE(object)						\
49    ((long)(object) >> LABEL_BIT_COUNT)
50
51#define READ_ENTER()							\
52    LispObj *read__stream = SINPUT;					\
53    int read__line = LispGetLine(read__stream)
54#define READ_ERROR0(format)						\
55    LispReadError(read__stream, read__line, format)
56#define READ_ERROR1(format, arg1)					\
57    LispReadError(read__stream, read__line, format, arg1)
58#define READ_ERROR2(format, arg1, arg2)					\
59    LispReadError(read__stream, read__line, format, arg1, arg2)
60
61#define READ_ERROR_EOF()	READ_ERROR0("unexpected end of input")
62#define READ_ERROR_FIXNUM()	READ_ERROR0("number is not a fixnum")
63#define READ_ERROR_INVARG()	READ_ERROR0("invalid argument")
64
65#ifdef __APPLE__
66# define finite(x) isfinite(x)
67#endif
68
69/*
70 * Types
71 */
72typedef struct _object_info {
73    long label;		/* the read label of this object */
74    LispObj *object;	/* the resulting object */
75    long num_circles;	/* references to object before it was completely read */
76} object_info;
77
78typedef struct _read_info {
79    int level;		/* level of open parentheses */
80
81    int nodot;		/* flag set when reading a "special" list */
82
83    int discard;	/* flag used when reading an unavailable feature */
84
85    long circle_count;	/* if non zero, must resolve some labels */
86
87    /* information for #<number>= and #<number># */
88    object_info *objects;
89    long num_objects;
90
91    /* could use only the objects field as all circular data is known,
92     * but check every object so that circular/shared references generated
93     * by evaluations would not cause an infinite loop at read time */
94    LispObj **circles;
95    long num_circles;
96} read_info;
97
98/*
99 * Protypes
100 */
101static LispObj *LispReadChar(LispBuiltin*, int);
102
103static int LispGetLine(LispObj*);
104#ifdef __GNUC__
105#define PRINTF_FORMAT	__attribute__ ((format (printf, 3, 4)))
106#else
107#define PRINTF_FORMAT	/**/
108#endif
109static void LispReadError(LispObj*, int, const char*, ...);
110#undef PRINTF_FORMAT
111static void LispReadFixCircle(LispObj*, read_info*);
112static LispObj *LispReadLabelCircle(LispObj*, read_info*);
113static int LispReadCheckCircle(LispObj*, read_info*);
114static LispObj *LispDoRead(read_info*);
115static int LispSkipWhiteSpace(void);
116static LispObj *LispReadList(read_info*);
117static LispObj *LispReadQuote(read_info*);
118static LispObj *LispReadBackquote(read_info*);
119static LispObj *LispReadCommaquote(read_info*);
120static LispObj *LispReadObject(int, read_info*);
121static LispObj *LispParseAtom(char*, char*, int, int, LispObj*, int);
122static LispObj *LispParseNumber(char*, int, LispObj*, int);
123static int StringInRadix(char*, int, int);
124static int AtomSeparator(int, int, int);
125static LispObj *LispReadVector(read_info*);
126static LispObj *LispReadMacro(read_info*);
127static LispObj *LispReadFunction(read_info*);
128static LispObj *LispReadRational(int, read_info*);
129static LispObj *LispReadCharacter(read_info*);
130static void LispSkipComment(void);
131static LispObj *LispReadEval(read_info*);
132static LispObj *LispReadComplex(read_info*);
133static LispObj *LispReadPathname(read_info*);
134static LispObj *LispReadStruct(read_info*);
135static LispObj *LispReadMacroArg(read_info*);
136static LispObj *LispReadArray(long, read_info*);
137static LispObj *LispReadFeature(int, read_info*);
138static LispObj *LispEvalFeature(LispObj*);
139
140/*
141 * Initialization
142 */
143static const char * const Char_Nul[] = {"Null", "Nul", NULL};
144static const char * const Char_Soh[] = {"Soh", NULL};
145static const char * const Char_Stx[] = {"Stx", NULL};
146static const char * const Char_Etx[] = {"Etx", NULL};
147static const char * const Char_Eot[] = {"Eot", NULL};
148static const char * const Char_Enq[] = {"Enq", NULL};
149static const char * const Char_Ack[] = {"Ack", NULL};
150static const char * const Char_Bel[] = {"Bell", "Bel", NULL};
151static const char * const Char_Bs[]  = {"Backspace", "Bs", NULL};
152static const char * const Char_Tab[] = {"Tab", NULL};
153static const char * const Char_Nl[]  = {"Newline", "Nl", "Lf", "Linefeed", NULL};
154static const char * const Char_Vt[]  = {"Vt", NULL};
155static const char * const Char_Np[]  = {"Page", "Np", NULL};
156static const char * const Char_Cr[]  = {"Return", "Cr", NULL};
157static const char * const Char_Ff[]  = {"So", "Ff", NULL};
158static const char * const Char_Si[]  = {"Si", NULL};
159static const char * const Char_Dle[] = {"Dle", NULL};
160static const char * const Char_Dc1[] = {"Dc1", NULL};
161static const char * const Char_Dc2[] = {"Dc2", NULL};
162static const char * const Char_Dc3[] = {"Dc3", NULL};
163static const char * const Char_Dc4[] = {"Dc4", NULL};
164static const char * const Char_Nak[] = {"Nak", NULL};
165static const char * const Char_Syn[] = {"Syn", NULL};
166static const char * const Char_Etb[] = {"Etb", NULL};
167static const char * const Char_Can[] = {"Can", NULL};
168static const char * const Char_Em[]  = {"Em", NULL};
169static const char * const Char_Sub[] = {"Sub", NULL};
170static const char * const Char_Esc[] = {"Escape", "Esc", NULL};
171static const char * const Char_Fs[]  = {"Fs", NULL};
172static const char * const Char_Gs[]  = {"Gs", NULL};
173static const char * const Char_Rs[]  = {"Rs", NULL};
174static const char * const Char_Us[]  = {"Us", NULL};
175static const char * const Char_Sp[]  = {"Space", "Sp", NULL};
176static const char * const Char_Del[] = {"Rubout", "Del", "Delete", NULL};
177
178const LispCharInfo LispChars[256] = {
179    {Char_Nul},
180    {Char_Soh},
181    {Char_Stx},
182    {Char_Etx},
183    {Char_Eot},
184    {Char_Enq},
185    {Char_Ack},
186    {Char_Bel},
187    {Char_Bs},
188    {Char_Tab},
189    {Char_Nl},
190    {Char_Vt},
191    {Char_Np},
192    {Char_Cr},
193    {Char_Ff},
194    {Char_Si},
195    {Char_Dle},
196    {Char_Dc1},
197    {Char_Dc2},
198    {Char_Dc3},
199    {Char_Dc4},
200    {Char_Nak},
201    {Char_Syn},
202    {Char_Etb},
203    {Char_Can},
204    {Char_Em},
205    {Char_Sub},
206    {Char_Esc},
207    {Char_Fs},
208    {Char_Gs},
209    {Char_Rs},
210    {Char_Us},
211    {Char_Sp},
212    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
213    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
214    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
215    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
216    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
217    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
218    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
219    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
220    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
221    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
222    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
223    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
224    {Char_Del},
225    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
226    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
227    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
228    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
229    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
230    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
231    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
232    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
233    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
234    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
235    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
236    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
237    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
238    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
239    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
240    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}
241
242};
243
244Atom_id Sand, Sor, Snot;
245
246
247/*
248 * Implementation
249 */
250LispObj *
251Lisp_Read(LispBuiltin *builtin)
252/*
253 read &optional input-stream eof-error-p eof-value recursive-p
254 */
255{
256    LispObj *result;
257
258    LispObj *input_stream, *eof_error_p, *eof_value;
259
260    eof_value = ARGUMENT(2);
261    eof_error_p = ARGUMENT(1);
262    input_stream = ARGUMENT(0);
263
264    if (input_stream == UNSPEC)
265	input_stream = NIL;
266    else if (input_stream != NIL) {
267	CHECK_STREAM(input_stream);
268	else if (!input_stream->data.stream.readable)
269	    LispDestroy("%s: stream %s is not readable",
270			STRFUN(builtin), STROBJ(input_stream));
271	LispPushInput(input_stream);
272    }
273    else if (CONSP(lisp__data.input_list)) {
274	input_stream = STANDARD_INPUT;
275	LispPushInput(input_stream);
276    }
277
278    if (eof_value == UNSPEC)
279	eof_value = NIL;
280
281    result = LispRead();
282    if (input_stream != NIL)
283	LispPopInput(input_stream);
284
285    if (result == NULL) {
286	if (eof_error_p != NIL)
287	    LispDestroy("%s: EOF reading stream %s",
288			STRFUN(builtin), STROBJ(input_stream));
289	else
290	    result = eof_value;
291    }
292
293    return (result);
294}
295
296static LispObj *
297LispReadChar(LispBuiltin *builtin, int nohang)
298{
299    int character;
300
301    LispObj *input_stream, *eof_error_p, *eof_value;
302
303    eof_value = ARGUMENT(2);
304    eof_error_p = ARGUMENT(1);
305    input_stream = ARGUMENT(0);
306
307    if (input_stream == UNSPEC)
308	input_stream = NIL;
309    else if (input_stream != NIL) {
310	CHECK_STREAM(input_stream);
311    }
312    else
313	input_stream = lisp__data.input;
314
315    if (eof_value == UNSPEC)
316	eof_value = NIL;
317
318    character = EOF;
319
320    if (input_stream->data.stream.readable) {
321	LispFile *file = NULL;
322
323	switch (input_stream->data.stream.type) {
324	    case LispStreamStandard:
325	    case LispStreamFile:
326		file = FSTREAMP(input_stream);
327		break;
328	    case LispStreamPipe:
329		file = IPSTREAMP(input_stream);
330		break;
331	    case LispStreamString:
332		character = LispSgetc(SSTREAMP(input_stream));
333		break;
334	    default:
335		break;
336	}
337	if (file != NULL) {
338	    if (file->available || file->offset < file->length)
339		character = LispFgetc(file);
340	    else {
341		if (nohang && !file->nonblock) {
342		    if (fcntl(file->descriptor, F_SETFL, O_NONBLOCK) < 0)
343			LispDestroy("%s: fcntl(%d): %s",
344				    STRFUN(builtin), file->descriptor,
345				    strerror(errno));
346		    file->nonblock = 1;
347		}
348		else if (!nohang && file->nonblock) {
349		    if (fcntl(file->descriptor, F_SETFL, 0) < 0)
350			LispDestroy("%s: fcntl(%d): %s",
351				    STRFUN(builtin), file->descriptor,
352				    strerror(errno));
353		    file->nonblock = 0;
354		}
355		if (nohang) {
356		    unsigned char ch;
357
358		    if (read(file->descriptor, &ch, 1) == 1)
359			character = ch;
360		    else if (errno == EAGAIN)
361			return (NIL);	/* XXX no character available */
362		    else
363			character = EOF;
364		}
365		else
366		    character = LispFgetc(file);
367	    }
368	}
369    }
370    else
371	LispDestroy("%s: stream %s is unreadable",
372		    STRFUN(builtin), STROBJ(input_stream));
373
374    if (character == EOF) {
375	if (eof_error_p != NIL)
376	    LispDestroy("%s: EOF reading stream %s",
377			STRFUN(builtin), STROBJ(input_stream));
378
379	return (eof_value);
380    }
381
382    return (SCHAR(character));
383}
384
385LispObj *
386Lisp_ReadChar(LispBuiltin *builtin)
387/*
388 read-char &optional input-stream eof-error-p eof-value recursive-p
389 */
390{
391    return (LispReadChar(builtin, 0));
392}
393
394LispObj *
395Lisp_ReadCharNoHang(LispBuiltin *builtin)
396/*
397 read-char-no-hang &optional input-stream eof-error-p eof-value recursive-p
398 */
399{
400    return (LispReadChar(builtin, 1));
401}
402
403LispObj *
404Lisp_ReadLine(LispBuiltin *builtin)
405/*
406 read-line &optional input-stream eof-error-p eof-value recursive-p
407 */
408{
409    char *string;
410    int ch, length;
411    LispObj *result, *status = NIL;
412
413    LispObj *input_stream, *eof_error_p, *eof_value;
414
415    eof_value = ARGUMENT(2);
416    eof_error_p = ARGUMENT(1);
417    input_stream = ARGUMENT(0);
418
419    if (input_stream == UNSPEC)
420	input_stream = NIL;
421    else if (input_stream == NIL)
422	input_stream = STANDARD_INPUT;
423    else {
424	CHECK_STREAM(input_stream);
425    }
426
427    if (eof_value == UNSPEC)
428	eof_value = NIL;
429
430    result = NIL;
431    string = NULL;
432    length = 0;
433
434    if (!input_stream->data.stream.readable)
435	LispDestroy("%s: stream %s is unreadable",
436		    STRFUN(builtin), STROBJ(input_stream));
437    if (input_stream->data.stream.type == LispStreamString) {
438	char *start, *end, *ptr;
439
440	if (SSTREAMP(input_stream)->input >=
441	    SSTREAMP(input_stream)->length) {
442	    if (eof_error_p != NIL)
443		LispDestroy("%s: EOS found reading %s",
444			    STRFUN(builtin), STROBJ(input_stream));
445
446	    status = T;
447	    result = eof_value;
448	    goto read_line_done;
449	}
450
451	start = SSTREAMP(input_stream)->string +
452		SSTREAMP(input_stream)->input;
453	end = SSTREAMP(input_stream)->string +
454	      SSTREAMP(input_stream)->length;
455	/* Search for a newline */
456	for (ptr = start; *ptr != '\n' && ptr < end; ptr++)
457	    ;
458	if (ptr == end)
459	    status = T;
460	else if (!SSTREAMP(input_stream)->binary)
461	    ++SSTREAMP(input_stream)->line;
462	length = ptr - start;
463	string = LispMalloc(length + 1);
464	memcpy(string, start, length);
465	string[length] = '\0';
466	result = LSTRING2(string, length);
467	/* macro LSTRING2 does not make a copy of it's arguments, and
468	 * calls LispMused on it. */
469	SSTREAMP(input_stream)->input += length + (status == NIL);
470    }
471    else /*if (input_stream->data.stream.type == LispStreamFile ||
472	     input_stream->data.stream.type == LispStreamStandard ||
473	     input_stream->data.stream.type == LispStreamPipe)*/ {
474	LispFile *file;
475
476	if (input_stream->data.stream.type == LispStreamPipe)
477	    file = IPSTREAMP(input_stream);
478	else
479	    file = FSTREAMP(input_stream);
480
481	if (file->nonblock) {
482	    if (fcntl(file->descriptor, F_SETFL, 0) < 0)
483		LispDestroy("%s: fcntl: %s",
484			    STRFUN(builtin), strerror(errno));
485	    file->nonblock = 0;
486	}
487
488	while (1) {
489	    ch = LispFgetc(file);
490	    if (ch == EOF) {
491		if (length)
492		    break;
493		if (eof_error_p != NIL)
494		    LispDestroy("%s: EOF found reading %s",
495				STRFUN(builtin), STROBJ(input_stream));
496		if (string)
497		    LispFree(string);
498
499		status = T;
500		result = eof_value;
501		goto read_line_done;
502	    }
503	    else if (ch == '\n')
504		break;
505	    else if ((length % 64) == 0)
506		string = LispRealloc(string, length + 64);
507	    string[length++] = ch;
508	}
509	if (string) {
510	    if ((length % 64) == 0)
511		string = LispRealloc(string, length + 1);
512	    string[length] = '\0';
513	    result = LSTRING2(string, length);
514	}
515	else
516	    result = STRING("");
517    }
518
519read_line_done:
520    RETURN(0) = status;
521    RETURN_COUNT = 1;
522
523    return (result);
524}
525
526LispObj *
527LispRead(void)
528{
529    READ_ENTER();
530    read_info info;
531    LispObj *result, *code = COD;
532
533    info.level = info.nodot = info.discard = 0;
534    info.circle_count = 0;
535    info.objects = NULL;
536    info.num_objects = 0;
537
538    result = LispDoRead(&info);
539
540    /* fix circular/shared lists, note that this is done when returning to
541     * the toplevel, so, if some circular/shared reference was evaluated,
542     * it should have generated an expected error */
543    if (info.num_objects) {
544	if (info.circle_count) {
545	    info.circles = NULL;
546	    info.num_circles = 0;
547	    LispReadFixCircle(result, &info);
548	    if (info.num_circles)
549		LispFree(info.circles);
550	}
551	LispFree(info.objects);
552    }
553
554    if (result == EOLIST)
555	READ_ERROR0("object cannot start with #\\)");
556    else if (result == DOT)
557	READ_ERROR0("dot allowed only on lists");
558
559    if (result != NULL && POINTERP(result)) {
560	if (code == NIL)
561	    COD = result;
562	else
563	    COD = CONS(COD, result);
564    }
565
566    return (result);
567}
568
569static int
570LispGetLine(LispObj *stream)
571{
572    int line = -1;
573
574    if (STREAMP(stream)) {
575	switch (stream->data.stream.type) {
576	    case LispStreamStandard:
577	    case LispStreamFile:
578		if (!FSTREAMP(stream)->binary)
579		    line = FSTREAMP(stream)->line;
580		break;
581	    case LispStreamPipe:
582		if (!IPSTREAMP(stream)->binary)
583		    line = IPSTREAMP(stream)->line;
584		break;
585	    case LispStreamString:
586		if (!SSTREAMP(stream)->binary)
587		    line = SSTREAMP(stream)->line;
588		break;
589	    default:
590		break;
591	}
592    }
593    else if (stream == NIL && !Stdin->binary)
594	line = Stdin->line;
595
596    return (line);
597}
598
599static void
600LispReadError(LispObj *stream, int line, const char *fmt, ...)
601{
602    char string[128];
603    const char *buffer_string;
604    LispObj *buffer = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
605    int length;
606    va_list ap;
607
608    va_start(ap, fmt);
609    vsnprintf(string, sizeof(string), fmt, ap);
610    va_end(ap);
611
612    LispFwrite(Stderr, "*** Reading ", 12);
613    LispWriteObject(buffer, stream);
614    buffer_string = LispGetSstring(SSTREAMP(buffer), &length);
615    LispFwrite(Stderr, buffer_string, length);
616    LispFwrite(Stderr, " at line ", 9);
617    if (line < 0)
618	LispFwrite(Stderr, "?\n", 2);
619    else {
620	char str[32];
621
622	sprintf(str, "%d\n", line);
623	LispFputs(Stderr, str);
624    }
625
626    LispDestroy("READ: %s", string);
627}
628
629static void
630LispReadFixCircle(LispObj *object, read_info *info)
631{
632    LispObj *cons;
633
634fix_again:
635    switch (OBJECT_TYPE(object)) {
636	case LispCons_t:
637	    for (cons = object;
638		 CONSP(object);
639		 cons = object, object = CDR(object)) {
640		if (READLABELP(CAR(object)))
641		    CAR(object) = LispReadLabelCircle(CAR(object), info);
642		else if (LispReadCheckCircle(object, info))
643		    return;
644		else
645		    LispReadFixCircle(CAR(object), info);
646	    }
647	    if (READLABELP(object))
648		CDR(cons) = LispReadLabelCircle(object, info);
649	    else
650		goto fix_again;
651	    break;
652	case LispArray_t:
653	    if (READLABELP(object->data.array.list))
654		object->data.array.list =
655		    LispReadLabelCircle(object->data.array.list, info);
656	    else if (!LispReadCheckCircle(object, info)) {
657		object = object->data.array.list;
658		goto fix_again;
659	    }
660	    break;
661	case LispStruct_t:
662	    if (READLABELP(object->data.struc.fields))
663		object->data.struc.fields =
664		    LispReadLabelCircle(object->data.struc.fields, info);
665	    else if (!LispReadCheckCircle(object, info)) {
666		object = object->data.struc.fields;
667		goto fix_again;
668	    }
669	    break;
670	case LispQuote_t:
671	case LispBackquote_t:
672	case LispFunctionQuote_t:
673	    if (READLABELP(object->data.quote))
674		object->data.quote =
675		    LispReadLabelCircle(object->data.quote, info);
676	    else {
677		object = object->data.quote;
678		goto fix_again;
679	    }
680	    break;
681	case LispComma_t:
682	    if (READLABELP(object->data.comma.eval))
683		object->data.comma.eval =
684		    LispReadLabelCircle(object->data.comma.eval, info);
685	    else {
686		object = object->data.comma.eval;
687		goto fix_again;
688	    }
689	    break;
690	case LispLambda_t:
691	    if (READLABELP(object->data.lambda.code))
692		object->data.lambda.code =
693		    LispReadLabelCircle(object->data.lambda.code, info);
694	    else if (!LispReadCheckCircle(object, info)) {
695		object = object->data.lambda.code;
696		goto fix_again;
697	    }
698	    break;
699	default:
700	    break;
701    }
702}
703
704static LispObj *
705LispReadLabelCircle(LispObj *label, read_info *info)
706{
707    long i, value = READLABEL_VALUE(label);
708
709    for (i = 0; i < info->num_objects; i++)
710	if (info->objects[i].label == value)
711	    return (info->objects[i].object);
712
713    LispDestroy("READ: internal error");
714    /*NOTREACHED*/
715    return (label);
716}
717
718static int
719LispReadCheckCircle(LispObj *object, read_info *info)
720{
721    long i;
722
723    for (i = 0; i < info->num_circles; i++)
724	if (info->circles[i] == object)
725	    return (1);
726
727    if ((info->num_circles % 16) == 0)
728	info->circles = LispRealloc(info->circles, sizeof(LispObj*) *
729				    (info->num_circles + 16));
730    info->circles[info->num_circles++] = object;
731
732    return (0);
733}
734
735static LispObj *
736LispDoRead(read_info *info)
737{
738    LispObj *object;
739    int ch = LispSkipWhiteSpace();
740
741    switch (ch) {
742	case '(':
743	    object = LispReadList(info);
744	    break;
745	case ')':
746	    for (ch = LispGet(); ch != EOF && ch != '\n'; ch = LispGet()) {
747		if (!isspace(ch)) {
748		    LispUnget(ch);
749		    break;
750		}
751	    }
752	    return (EOLIST);
753	case EOF:
754	    return (NULL);
755	case '\'':
756	    object = LispReadQuote(info);
757	    break;
758	case '`':
759	    object = LispReadBackquote(info);
760	    break;
761	case ',':
762	    object = LispReadCommaquote(info);
763	    break;
764	case '#':
765	    object = LispReadMacro(info);
766	    break;
767	default:
768	    LispUnget(ch);
769	    object = LispReadObject(0, info);
770	    break;
771    }
772
773    return (object);
774}
775
776static LispObj *
777LispReadMacro(read_info *info)
778{
779    READ_ENTER();
780    LispObj *result = NULL;
781    int ch = LispGet();
782
783    switch (ch) {
784	case '(':
785	    result = LispReadVector(info);
786	    break;
787	case '\'':
788	   result = LispReadFunction(info);
789	   break;
790	case 'b':
791	case 'B':
792	    result = LispReadRational(2, info);
793	    break;
794	case 'o':
795	case 'O':
796	    result = LispReadRational(8, info);
797	    break;
798	case 'x':
799	case 'X':
800	    result = LispReadRational(16, info);
801	    break;
802	case '\\':
803	    result = LispReadCharacter(info);
804	    break;
805	case '|':
806	    LispSkipComment();
807	    result = LispDoRead(info);
808	    break;
809	case '.':	/* eval when compiling */
810	case ',':	/* eval when loading */
811	    result = LispReadEval(info);
812	    break;
813	case 'c':
814	case 'C':
815	    result = LispReadComplex(info);
816	    break;
817	case 'p':
818	case 'P':
819	    result = LispReadPathname(info);
820	    break;
821	case 's':
822	case 'S':
823	    result = LispReadStruct(info);
824	    break;
825	case '+':
826	    result = LispReadFeature(1, info);
827	    break;
828	case '-':
829	    result = LispReadFeature(0, info);
830	    break;
831	case ':':
832	    /* Uninterned symbol */
833	    result = LispReadObject(1, info);
834	    break;
835	default:
836	    if (isdigit(ch)) {
837		LispUnget(ch);
838		result = LispReadMacroArg(info);
839	    }
840	    else if (!info->discard)
841		READ_ERROR1("undefined dispatch macro character #%c", ch);
842	    break;
843    }
844
845    return (result);
846}
847
848static LispObj *
849LispReadMacroArg(read_info *info)
850{
851    READ_ENTER();
852    LispObj *result = NIL;
853    long i, integer;
854    int ch;
855
856    /* skip leading zeros */
857    while (ch = LispGet(), ch != EOF && isdigit(ch) && ch == '0')
858	;
859
860    if (ch == EOF)
861	READ_ERROR_EOF();
862
863    /* if ch is not a number the argument was zero */
864    if (isdigit(ch)) {
865	char stk[32], *str;
866	int len = 1;
867
868	stk[0] = ch;
869	for (;;) {
870	    ch = LispGet();
871	    if (!isdigit(ch))
872		break;
873	    if (len + 1 >= sizeof(stk))
874		READ_ERROR_FIXNUM();
875	    stk[len++] = ch;
876	}
877	stk[len] = '\0';
878	errno = 0;
879	integer = strtol(stk, &str, 10);
880	/* number is positive because sign is not processed here */
881	if (*str || errno == ERANGE || integer > MOST_POSITIVE_FIXNUM)
882	    READ_ERROR_FIXNUM();
883    }
884    else
885	integer = 0;
886
887    switch (ch) {
888	case 'a':
889	case 'A':
890	    if (integer == 1) {
891		/* LispReadArray and LispReadList expect
892		 * the '(' being already read  */
893		if ((ch = LispSkipWhiteSpace()) != '(') {
894		    if (info->discard)
895			return (ch == EOF ? NULL : NIL);
896		    READ_ERROR0("bad array specification");
897		}
898		result = LispReadVector(info);
899	    }
900	    else
901		result = LispReadArray(integer, info);
902	    break;
903	case 'r':
904	case 'R':
905	    result = LispReadRational(integer, info);
906	    break;
907	case '=':
908	    if (integer > MAX_LABEL_VALUE)
909		READ_ERROR_FIXNUM();
910	    if (!info->discard) {
911		long num_objects = info->num_objects;
912
913		/* check for duplicated label */
914		for (i = 0; i < info->num_objects; i++) {
915		    if (info->objects[i].label == integer)
916			READ_ERROR1("label #%ld# defined more than once",
917				    integer);
918		}
919		info->objects = LispRealloc(info->objects,
920					    sizeof(object_info) *
921					    (num_objects + 1));
922		/* if this label is referenced it is a shared/circular object */
923		info->objects[num_objects].label = integer;
924		info->objects[num_objects].object = NULL;
925		info->objects[num_objects].num_circles = 0;
926		++info->num_objects;
927		result = LispDoRead(info);
928		if (READLABELP(result) && READLABEL_VALUE(result) == integer)
929		    READ_ERROR2("incorrect syntax #%ld= #%ld#",
930				integer, integer);
931		/* any reference to it now is not shared/circular */
932		info->objects[num_objects].object = result;
933	    }
934	    else
935		result = LispDoRead(info);
936	    break;
937	case '#':
938	    if (integer > MAX_LABEL_VALUE)
939		READ_ERROR_FIXNUM();
940	    if (!info->discard) {
941		/* search object */
942		for (i = 0; i < info->num_objects; i++) {
943		    if (info->objects[i].label == integer) {
944			result = info->objects[i].object;
945			if (result == NULL) {
946			    ++info->objects[i].num_circles;
947			    ++info->circle_count;
948			    result = READLABEL(integer);
949			}
950			break;
951		    }
952		}
953		if (i == info->num_objects)
954		    READ_ERROR1("undefined label #%ld#", integer);
955	    }
956	    break;
957	default:
958	    if (!info->discard)
959		READ_ERROR1("undefined dispatch macro character #%c", ch);
960	    break;
961    }
962
963    return (result);
964}
965
966static int
967LispSkipWhiteSpace(void)
968{
969    int ch;
970
971    for (;;) {
972	while (ch = LispGet(), isspace(ch) && ch != EOF)
973	    ;
974	if (ch == ';') {
975	    while (ch = LispGet(), ch != '\n' && ch != EOF)
976		;
977	    if (ch == EOF)
978		return (EOF);
979	}
980	else
981	    break;
982    }
983
984    return (ch);
985}
986
987/* any data in the format '(' FORM ')' is read here */
988static LispObj *
989LispReadList(read_info *info)
990{
991    READ_ENTER();
992    GC_ENTER();
993    LispObj *result, *cons, *object;
994    int dot = 0;
995
996    ++info->level;
997    /* check for () */
998    object = LispDoRead(info);
999    if (object == EOLIST) {
1000	--info->level;
1001
1002	return (NIL);
1003    }
1004
1005    if (object == DOT)
1006	READ_ERROR0("illegal start of dotted list");
1007
1008    result = cons = CONS(object, NIL);
1009
1010    /* make sure GC will not release data being read */
1011    GC_PROTECT(result);
1012
1013    while ((object = LispDoRead(info)) != EOLIST) {
1014	if (object == NULL)
1015	    READ_ERROR_EOF();
1016	if (object == DOT) {
1017	    if (info->nodot == info->level)
1018		READ_ERROR0("dotted list not allowed");
1019	    /* this is a dotted list */
1020	    if (dot)
1021		READ_ERROR0("more than one . in list");
1022	    dot = 1;
1023	}
1024	else {
1025	    if (dot) {
1026		/* only one object after a dot */
1027		if (++dot > 2)
1028		    READ_ERROR0("more than one object after . in list");
1029		RPLACD(cons, object);
1030	    }
1031	    else {
1032		RPLACD(cons, CONS(object, NIL));
1033		cons = CDR(cons);
1034	    }
1035	}
1036    }
1037
1038    /* this will happen if last list element was a dot */
1039    if (dot == 1)
1040	READ_ERROR0("illegal end of dotted list");
1041
1042    --info->level;
1043    GC_LEAVE();
1044
1045    return (result);
1046}
1047
1048static LispObj *
1049LispReadQuote(read_info *info)
1050{
1051    READ_ENTER();
1052    LispObj *quote = LispDoRead(info), *result;
1053
1054    if (INVALIDP(quote))
1055	READ_ERROR_INVARG();
1056
1057    result = QUOTE(quote);
1058
1059    return (result);
1060}
1061
1062static LispObj *
1063LispReadBackquote(read_info *info)
1064{
1065    READ_ENTER();
1066    LispObj *backquote = LispDoRead(info), *result;
1067
1068    if (INVALIDP(backquote))
1069	READ_ERROR_INVARG();
1070
1071    result = BACKQUOTE(backquote);
1072
1073    return (result);
1074}
1075
1076static LispObj *
1077LispReadCommaquote(read_info *info)
1078{
1079    READ_ENTER();
1080    LispObj *comma, *result;
1081    int atlist = LispGet();
1082
1083    if (atlist == EOF)
1084	READ_ERROR_EOF();
1085    else if (atlist != '@' && atlist != '.')
1086	LispUnget(atlist);
1087
1088    comma = LispDoRead(info);
1089    if (comma == DOT) {
1090	atlist = '@';
1091	comma = LispDoRead(info);
1092    }
1093    if (INVALIDP(comma))
1094	READ_ERROR_INVARG();
1095
1096    result = COMMA(comma, atlist == '@' || atlist == '.');
1097
1098    return (result);
1099}
1100
1101/*
1102 * Read anything that is not readily identifiable by it's first character
1103 * and also put the code for reading atoms, numbers and strings together.
1104 */
1105static LispObj *
1106LispReadObject(int unintern, read_info *info)
1107{
1108    READ_ENTER();
1109    LispObj *object;
1110    char stk[128], *string, *package, *symbol;
1111    int ch, length, backslash, size, quote, unreadable, collon;
1112
1113    package = symbol = string = stk;
1114    size = sizeof(stk);
1115    backslash = quote = unreadable = collon = 0;
1116    length = 0;
1117
1118    ch = LispGet();
1119    if (unintern && (ch == ':' || ch == '"'))
1120	READ_ERROR0("syntax error after #:");
1121    else if (ch == '"' || ch == '|')
1122	quote = ch;
1123    else if (ch == '\\') {
1124	unreadable = backslash = 1;
1125	string[length++] = ch;
1126    }
1127    else if (ch == ':') {
1128	collon = 1;
1129	string[length++] = ch;
1130	symbol = string + 1;
1131	ch = LispGet();
1132	if (ch == '|') {
1133	    quote = ch;
1134	    unreadable = 1;
1135	}
1136	else if (ch != EOF)
1137	    LispUnget(ch);
1138    }
1139    else if (ch) {
1140	if (islower(ch))
1141	    ch = toupper(ch);
1142	string[length++] = ch;
1143    }
1144    else
1145	unreadable = 1;
1146
1147    /* read remaining data */
1148    for (; ch;) {
1149	ch = LispGet();
1150
1151	if (ch == EOF) {
1152	    if (quote) {
1153		/* if quote, file ended with an open quoted object */
1154		if (string != stk)
1155		    LispFree(string);
1156		return (NULL);
1157	    }
1158	    break;
1159	}
1160	else if (ch == '\0')
1161	    break;
1162
1163	if (ch == '\\') {
1164	    backslash = !backslash;
1165	    if (quote == '"') {
1166		/* only remove backslashs from strings */
1167		if (backslash)
1168		    continue;
1169	    }
1170	    else
1171		unreadable = 1;
1172	}
1173	else if (backslash)
1174	    backslash = 0;
1175	else if (ch == quote)
1176	    break;
1177	else if (!quote && !backslash) {
1178	    if (islower(ch))
1179		ch = toupper(ch);
1180	    else if (isspace(ch))
1181		break;
1182	    else if (AtomSeparator(ch, 0, 0)) {
1183		LispUnget(ch);
1184		break;
1185	    }
1186	    else if (ch == ':') {
1187		if (collon == 0 ||
1188		    (collon == (1 - unintern) && symbol == string + length)) {
1189		    ++collon;
1190		    symbol = string + length + 1;
1191		}
1192		else
1193		    READ_ERROR0("too many collons");
1194	    }
1195	}
1196
1197	if (length + 2 >= size) {
1198	    if (string == stk) {
1199		size = 1024;
1200		string = LispMalloc(size);
1201		strcpy(string, stk);
1202	    }
1203	    else {
1204		size += 1024;
1205		string = LispRealloc(string, size);
1206	    }
1207	    symbol = string + (symbol - package);
1208	    package = string;
1209	}
1210	string[length++] = ch;
1211    }
1212
1213    if (info->discard) {
1214	if (string != stk)
1215	    LispFree(string);
1216
1217	return (ch == EOF ? NULL : NIL);
1218    }
1219
1220    string[length] = '\0';
1221
1222    if (unintern) {
1223	if (length == 0)
1224	    READ_ERROR0("syntax error after #:");
1225	object = UNINTERNED_ATOM(string);
1226    }
1227
1228    else if (quote == '"')
1229	object = LSTRING(string, length);
1230
1231    else if (collon) {
1232	/* Package specified in object name */
1233	symbol[-1] = '\0';
1234	if (collon > 1)
1235	    symbol[-2] = '\0';
1236	object = LispParseAtom(package, symbol,
1237			       collon == 2, unreadable,
1238			       read__stream, read__line);
1239    }
1240
1241    else if (quote == '|' || (unreadable && !collon)) {
1242	/* Set unreadable field, this atom needs quoting to be read back */
1243	object = ATOM(string);
1244	object->data.atom->unreadable = 1;
1245    }
1246
1247    /* Check some common symbols */
1248    else if (length == 1 && string[0] == 'T')
1249	/* The T */
1250	object = T;
1251
1252    else if (length == 1 && string[0] == '.')
1253	/* The dot */
1254	object = DOT;
1255
1256    else if (length == 3 &&
1257	     string[0] == 'N' && string[1] == 'I' && string[2] == 'L')
1258	/* The NIL */
1259	object = NIL;
1260
1261    else if (isdigit(string[0]) || string[0] == '.' ||
1262	     ((string[0] == '-' || string[0] == '+') && string[1]))
1263	/* Looks like a number */
1264	object = LispParseNumber(string, 10, read__stream, read__line);
1265
1266    else
1267	/* A normal atom */
1268	object = ATOM(string);
1269
1270    if (string != stk)
1271	LispFree(string);
1272
1273    return (object);
1274}
1275
1276static LispObj *
1277LispParseAtom(char *package, char *symbol, int intern, int unreadable,
1278	      LispObj *read__stream, int read__line)
1279{
1280    LispObj *object = NULL, *thepackage = NULL;
1281    LispPackage *pack = NULL;
1282
1283    if (!unreadable) {
1284	/* Until NIL and T be treated as normal symbols */
1285	if (symbol[0] == 'N' && symbol[1] == 'I' &&
1286	    symbol[2] == 'L' && symbol[3] == '\0')
1287	    return (NIL);
1288	if (symbol[0] == 'T' && symbol[1] == '\0')
1289	    return (T);
1290	unreadable = !LispCheckAtomString(symbol);
1291    }
1292
1293    /* If package is empty, it is a keyword */
1294    if (package[0] == '\0') {
1295	thepackage = lisp__data.keyword;
1296	pack = lisp__data.key;
1297    }
1298
1299    else {
1300	/* Else, search it in the package list */
1301	thepackage = LispFindPackageFromString(package);
1302
1303	if (thepackage == NIL)
1304	    READ_ERROR1("the package %s is not available", package);
1305
1306	pack = thepackage->data.package.package;
1307    }
1308
1309    if (pack == lisp__data.pack && intern) {
1310	/* Redundant package specification, since requesting a
1311	 * intern symbol, create it if does not exist */
1312
1313	object = ATOM(symbol);
1314	if (unreadable)
1315	    object->data.atom->unreadable = 1;
1316    }
1317
1318    else if (intern || pack == lisp__data.key) {
1319	/* Symbol is created, or just fetched from the specified package */
1320
1321	LispPackage *savepack;
1322	LispObj *savepackage = PACKAGE;
1323
1324	/* Remember curent package */
1325	savepack = lisp__data.pack;
1326
1327	/* Temporarily set another package */
1328	lisp__data.pack = pack;
1329	PACKAGE = thepackage;
1330
1331	/* Get the object pointer */
1332	if (pack == lisp__data.key)
1333	    object = KEYWORD(LispDoGetAtom(symbol, 0)->key->value);
1334	else
1335	    object = ATOM(symbol);
1336	if (unreadable)
1337	    object->data.atom->unreadable = 1;
1338
1339	/* Restore current package */
1340	lisp__data.pack = savepack;
1341	PACKAGE = savepackage;
1342    }
1343
1344    else {
1345	/* Symbol must exist (and be extern) in the specified package */
1346
1347	LispAtom *atom;
1348
1349	atom = (LispAtom *)hash_check(pack->atoms, symbol, strlen(symbol));
1350	if (atom)
1351	    object = atom->object;
1352
1353	/* No object found */
1354	if (object == NULL || object->data.atom->ext == 0)
1355	    READ_ERROR2("no extern symbol %s in package %s", symbol, package);
1356    }
1357
1358    return (object);
1359}
1360
1361static LispObj *
1362LispParseNumber(char *str, int radix, LispObj *read__stream, int read__line)
1363{
1364    int len;
1365    long integer;
1366    double dfloat;
1367    char *ratio, *ptr;
1368    LispObj *number;
1369    mpi *bignum;
1370    mpr *bigratio;
1371
1372    if (radix < 2 || radix > 36)
1373	READ_ERROR1("radix %d is not in the range 2 to 36", radix);
1374
1375    if (*str == '\0')
1376	return (NULL);
1377
1378    ratio = strchr(str, '/');
1379    if (ratio) {
1380	/* check if looks like a correctly specified ratio */
1381	if (ratio[1] == '\0' || strchr(ratio + 1, '/') != NULL)
1382	    return (ATOM(str));
1383
1384	/* ratio must point to an integer in radix base */
1385	*ratio++ = '\0';
1386    }
1387    else if (radix == 10) {
1388	int dot = 0;
1389	int type = 0;
1390
1391	/* check if it is a floating point number */
1392	ptr = str;
1393	if (*ptr == '-' || *ptr == '+')
1394	    ++ptr;
1395	else if (*ptr == '.') {
1396	    dot = 1;
1397	    ++ptr;
1398	}
1399	while (*ptr) {
1400	    if (*ptr == '.') {
1401		if (dot)
1402		    return (ATOM(str));
1403		/* ignore it if last char is a dot */
1404		if (ptr[1] == '\0') {
1405		    *ptr = '\0';
1406		    break;
1407		}
1408		dot = 1;
1409	    }
1410	    else if (!isdigit(*ptr))
1411		break;
1412	    ++ptr;
1413	}
1414
1415	switch (*ptr) {
1416	    case '\0':
1417		if (dot)		/* if dot, it is default float */
1418		    type = 'E';
1419		break;
1420	    case 'E': case 'S': case 'F': case 'D': case 'L':
1421		type = *ptr;
1422		*ptr = 'E';
1423		break;
1424	    default:
1425		return (ATOM(str));	/* syntax error */
1426	}
1427
1428	/* if type set, it is not an integer specification */
1429	if (type) {
1430	    if (*ptr) {
1431		int itype = *ptr;
1432		char *ptype = ptr;
1433
1434		++ptr;
1435		if (*ptr == '+' || *ptr == '-')
1436		    ++ptr;
1437		while (*ptr && isdigit(*ptr))
1438		    ++ptr;
1439		if (*ptr) {
1440		    *ptype = itype;
1441
1442		    return (ATOM(str));
1443		}
1444	    }
1445
1446	    dfloat = strtod(str, NULL);
1447	    if (!finite(dfloat))
1448		READ_ERROR0("floating point overflow");
1449
1450	    return (DFLOAT(dfloat));
1451	}
1452    }
1453
1454    /* check if correctly specified in the given radix */
1455    len = strlen(str) - 1;
1456    if (!ratio && radix != 10 && str[len] == '.')
1457	str[len] = '\0';
1458
1459    if (ratio || radix != 10) {
1460	if (!StringInRadix(str, radix, 1)) {
1461	    if (ratio)
1462		ratio[-1] = '/';
1463	    return (ATOM(str));
1464	}
1465	if (ratio && !StringInRadix(ratio, radix, 0)) {
1466	    ratio[-1] = '/';
1467	    return (ATOM(str));
1468	}
1469    }
1470
1471    bignum = NULL;
1472    bigratio = NULL;
1473
1474    errno = 0;
1475    integer = strtol(str, NULL, radix);
1476
1477    /* if does not fit in a long */
1478    if (errno == ERANGE) {
1479	bignum = LispMalloc(sizeof(mpi));
1480	mpi_init(bignum);
1481	mpi_setstr(bignum, str, radix);
1482    }
1483
1484
1485    if (ratio && integer != 0) {
1486	long denominator;
1487
1488	errno = 0;
1489	denominator = strtol(ratio, NULL, radix);
1490	if (denominator == 0)
1491	    READ_ERROR0("divide by zero");
1492
1493	if (bignum == NULL) {
1494	    if (integer == MINSLONG ||
1495		(denominator == LONG_MAX && errno == ERANGE)) {
1496		bigratio = LispMalloc(sizeof(mpr));
1497		mpr_init(bigratio);
1498		mpi_seti(mpr_num(bigratio), integer);
1499		mpi_setstr(mpr_den(bigratio), ratio, radix);
1500	    }
1501	}
1502	else {
1503	    bigratio = LispMalloc(sizeof(mpr));
1504	    mpr_init(bigratio);
1505	    mpi_set(mpr_num(bigratio), bignum);
1506	    mpi_clear(bignum);
1507	    LispFree(bignum);
1508	    mpi_setstr(mpr_den(bigratio), ratio, radix);
1509	}
1510
1511	if (bigratio) {
1512	    mpr_canonicalize(bigratio);
1513	    if (mpi_fiti(mpr_num(bigratio)) &&
1514		mpi_fiti(mpr_den(bigratio))) {
1515		integer = mpi_geti(mpr_num(bigratio));
1516		denominator = mpi_geti(mpr_den(bigratio));
1517		mpr_clear(bigratio);
1518		LispFree(bigratio);
1519		if (denominator == 1)
1520		    number = INTEGER(integer);
1521		else
1522		    number = RATIO(integer, denominator);
1523	    }
1524	    else
1525		number = BIGRATIO(bigratio);
1526	}
1527	else {
1528	    long num = integer, den = denominator, rest;
1529
1530	    if (num < 0)
1531		num = -num;
1532	    for (;;) {
1533		if ((rest = den % num) == 0)
1534		    break;
1535		den = num;
1536		num = rest;
1537	    }
1538	    if (den != 1) {
1539		denominator /= num;
1540		integer /= num;
1541	    }
1542	    if (denominator < 0) {
1543		integer = -integer;
1544		denominator = -denominator;
1545	    }
1546	    if (denominator == 1)
1547		number = INTEGER(integer);
1548	    else
1549		number = RATIO(integer, denominator);
1550	}
1551    }
1552    else if (bignum)
1553	number = BIGNUM(bignum);
1554    else
1555	number = INTEGER(integer);
1556
1557    return (number);
1558}
1559
1560static int
1561StringInRadix(char *str, int radix, int skip_sign)
1562{
1563    if (skip_sign && (*str == '-' || *str == '+'))
1564	++str;
1565    while (*str) {
1566	if (*str >= '0' && *str <= '9') {
1567	    if (*str - '0' >= radix)
1568		return (0);
1569	}
1570	else if (*str >= 'A' && *str <= 'Z') {
1571	    if (radix <= 10 || *str - 'A' + 10 >= radix)
1572		return (0);
1573	}
1574	else
1575	    return (0);
1576	str++;
1577    }
1578
1579    return (1);
1580}
1581
1582static int
1583AtomSeparator(int ch, int check_space, int check_backslash)
1584{
1585    if (check_space && isspace(ch))
1586	return (1);
1587    if (check_backslash && ch == '\\')
1588	return (1);
1589    return (strchr("(),\";'`#|,", ch) != NULL);
1590}
1591
1592static LispObj *
1593LispReadVector(read_info *info)
1594{
1595    LispObj *objects;
1596    int nodot = info->nodot;
1597
1598    info->nodot = info->level + 1;
1599    objects = LispReadList(info);
1600    info->nodot = nodot;
1601
1602    if (info->discard)
1603	return (objects);
1604
1605    return (VECTOR(objects));
1606}
1607
1608static LispObj *
1609LispReadFunction(read_info *info)
1610{
1611    READ_ENTER();
1612    int nodot = info->nodot;
1613    LispObj *function;
1614
1615    info->nodot = info->level + 1;
1616    function = LispDoRead(info);
1617    info->nodot = nodot;
1618
1619    if (info->discard)
1620	return (function);
1621
1622    if (INVALIDP(function))
1623	READ_ERROR_INVARG();
1624    else if (CONSP(function)) {
1625	if (CAR(function) != Olambda)
1626	    READ_ERROR_INVARG();
1627
1628	return (FUNCTION_QUOTE(function));
1629    }
1630    else if (!SYMBOLP(function))
1631	READ_ERROR_INVARG();
1632
1633    return (FUNCTION_QUOTE(function));
1634}
1635
1636static LispObj *
1637LispReadRational(int radix, read_info *info)
1638{
1639    READ_ENTER();
1640    LispObj *number;
1641    int ch, len, size;
1642    char stk[128], *str;
1643
1644    len = 0;
1645    str = stk;
1646    size = sizeof(stk);
1647
1648    for (;;) {
1649	ch = LispGet();
1650	if (ch == EOF || isspace(ch))
1651	    break;
1652	else if (AtomSeparator(ch, 0, 1)) {
1653	    LispUnget(ch);
1654	    break;
1655	}
1656	else if (islower(ch))
1657	    ch = toupper(ch);
1658	if ((ch < '0' || ch > '9') && (ch < 'A' || ch > 'Z') &&
1659	    ch != '+' && ch != '-' && ch != '/') {
1660	    if (str != stk)
1661		LispFree(str);
1662	    if (!info->discard)
1663		READ_ERROR1("bad character %c for rational number", ch);
1664	}
1665	if (len + 1 >= size) {
1666	    if (str == stk) {
1667		size = 512;
1668		str = LispMalloc(size);
1669		strcpy(str + 1, stk + 1);
1670	    }
1671	    else {
1672		size += 512;
1673		str = LispRealloc(str, size);
1674	    }
1675	}
1676	str[len++] = ch;
1677    }
1678
1679    if (info->discard) {
1680	if (str != stk)
1681	    LispFree(str);
1682
1683	return (ch == EOF ? NULL : NIL);
1684    }
1685
1686    str[len] = '\0';
1687
1688    number = LispParseNumber(str, radix, read__stream, read__line);
1689    if (str != stk)
1690	LispFree(str);
1691
1692    if (!RATIONALP(number))
1693	READ_ERROR0("bad rational number specification");
1694
1695    return (number);
1696}
1697
1698static LispObj *
1699LispReadCharacter(read_info *info)
1700{
1701    READ_ENTER();
1702    long c;
1703    int ch, len;
1704    char stk[64];
1705
1706    ch = LispGet();
1707    if (ch == EOF)
1708	return (NULL);
1709
1710    stk[0] = ch;
1711    len = 1;
1712
1713    for (;;) {
1714	ch = LispGet();
1715	if (ch == EOF)
1716	    break;
1717	else if (ch != '-' && !isalnum(ch)) {
1718	    LispUnget(ch);
1719	    break;
1720	}
1721	if (len + 1 < sizeof(stk))
1722	    stk[len++] = ch;
1723    }
1724    if (len > 1) {
1725	const char * const *names;
1726	int found = 0;
1727	stk[len] = '\0';
1728
1729	for (c = ch = 0; ch <= ' ' && !found; ch++) {
1730	    for (names = LispChars[ch].names; *names; names++)
1731		if (strcasecmp(*names, stk) == 0) {
1732		    c = ch;
1733		    found = 1;
1734		    break;
1735		}
1736	}
1737	if (!found) {
1738	    for (names = LispChars[0177].names; *names; names++)
1739		if (strcasecmp(*names, stk) == 0) {
1740		    c = 0177;
1741		    found = 1;
1742		    break;
1743		}
1744	}
1745
1746	if (!found) {
1747	    if (info->discard)
1748		return (NIL);
1749	    READ_ERROR1("unkwnown character %s", stk);
1750	}
1751    }
1752    else
1753	c = stk[0];
1754
1755    return (SCHAR(c));
1756}
1757
1758static void
1759LispSkipComment(void)
1760{
1761    READ_ENTER();
1762    int ch, comm = 1;
1763
1764    for (;;) {
1765	ch = LispGet();
1766	if (ch == '#') {
1767	    ch = LispGet();
1768	    if (ch == '|')
1769		++comm;
1770	    continue;
1771	}
1772	while (ch == '|') {
1773	    ch = LispGet();
1774	    if (ch == '#' && --comm == 0)
1775		return;
1776	}
1777	if (ch == EOF)
1778	    READ_ERROR_EOF();
1779    }
1780}
1781
1782static LispObj *
1783LispReadEval(read_info *info)
1784{
1785    READ_ENTER();
1786    int nodot = info->nodot;
1787    LispObj *code;
1788
1789    info->nodot = info->level + 1;
1790    code = LispDoRead(info);
1791    info->nodot = nodot;
1792
1793    if (info->discard)
1794	return (code);
1795
1796    if (INVALIDP(code))
1797	READ_ERROR_INVARG();
1798
1799    return (EVAL(code));
1800}
1801
1802static LispObj *
1803LispReadComplex(read_info *info)
1804{
1805    READ_ENTER();
1806    GC_ENTER();
1807    int nodot = info->nodot;
1808    LispObj *number, *arguments;
1809
1810    info->nodot = info->level + 1;
1811    arguments = LispDoRead(info);
1812    info->nodot = nodot;
1813
1814    /* form read */
1815    if (info->discard)
1816	return (arguments);
1817
1818    if (INVALIDP(arguments) || !CONSP(arguments))
1819	READ_ERROR_INVARG();
1820
1821    GC_PROTECT(arguments);
1822    number = APPLY(Ocomplex, arguments);
1823    GC_LEAVE();
1824
1825    return (number);
1826}
1827
1828static LispObj *
1829LispReadPathname(read_info *info)
1830{
1831    READ_ENTER();
1832    GC_ENTER();
1833    int nodot = info->nodot;
1834    LispObj *path, *arguments;
1835
1836    info->nodot = info->level + 1;
1837    arguments = LispDoRead(info);
1838    info->nodot = nodot;
1839
1840    /* form read */
1841    if (info->discard)
1842	return (arguments);
1843
1844    if (INVALIDP(arguments))
1845	READ_ERROR_INVARG();
1846
1847    GC_PROTECT(arguments);
1848    path = APPLY1(Oparse_namestring, arguments);
1849    GC_LEAVE();
1850
1851    return (path);
1852}
1853
1854static LispObj *
1855LispReadStruct(read_info *info)
1856{
1857    READ_ENTER();
1858    GC_ENTER();
1859    int len, nodot = info->nodot;
1860    char stk[128], *str;
1861    LispObj *struc, *fields;
1862
1863    info->nodot = info->level + 1;
1864    fields = LispDoRead(info);
1865    info->nodot = nodot;
1866
1867    /* form read */
1868    if (info->discard)
1869	return (fields);
1870
1871    if (INVALIDP(fields) || !CONSP(fields) || !SYMBOLP(CAR(fields)))
1872	READ_ERROR_INVARG();
1873
1874    GC_PROTECT(fields);
1875
1876    len = ATOMID(CAR(fields))->length;
1877	   /* MAKE- */
1878    if (len + 6 > sizeof(stk))
1879	str = LispMalloc(len + 6);
1880    else
1881	str = stk;
1882    sprintf(str, "MAKE-%s", ATOMID(CAR(fields))->value);
1883    RPLACA(fields, ATOM(str));
1884    if (str != stk)
1885	LispFree(str);
1886    struc = APPLY(Omake_struct, fields);
1887    GC_LEAVE();
1888
1889    return (struc);
1890}
1891
1892/* XXX This is broken, needs a rewritten as soon as true vector/arrays be
1893 * implemented. */
1894static LispObj *
1895LispReadArray(long dimensions, read_info *info)
1896{
1897    READ_ENTER();
1898    GC_ENTER();
1899    long count;
1900    int nodot = info->nodot;
1901    LispObj *arguments, *initial, *dim, *cons, *array, *data;
1902
1903    info->nodot = info->level + 1;
1904    data = LispDoRead(info);
1905    info->nodot = nodot;
1906
1907    /* form read */
1908    if (info->discard)
1909	return (data);
1910
1911    if (INVALIDP(data))
1912	READ_ERROR_INVARG();
1913
1914    initial = Kinitial_contents;
1915
1916    dim = cons = NIL;
1917    if (dimensions) {
1918	LispObj *array;
1919
1920	for (count = 0, array = data; count < dimensions; count++) {
1921	    long length;
1922	    LispObj *item;
1923
1924	    if (!CONSP(array))
1925		READ_ERROR0("bad array for given dimension");
1926	    item = array;
1927	    array = CAR(array);
1928
1929	    for (length = 0; CONSP(item); item = CDR(item), length++)
1930		;
1931
1932	    if (dim == NIL) {
1933		dim = cons = CONS(FIXNUM(length), NIL);
1934		GC_PROTECT(dim);
1935	    }
1936	    else {
1937		RPLACD(cons, CONS(FIXNUM(length), NIL));
1938		cons = CDR(cons);
1939	    }
1940	}
1941    }
1942
1943    arguments = CONS(dim, CONS(initial, CONS(data, NIL)));
1944    GC_PROTECT(arguments);
1945    array = APPLY(Omake_array, arguments);
1946    GC_LEAVE();
1947
1948    return (array);
1949}
1950
1951static LispObj *
1952LispReadFeature(int with, read_info *info)
1953{
1954    READ_ENTER();
1955    LispObj *status;
1956    LispObj *feature = LispDoRead(info);
1957
1958    /* form read */
1959    if (info->discard)
1960	return (feature);
1961
1962    if (INVALIDP(feature))
1963	READ_ERROR_INVARG();
1964
1965    /* paranoia check, features must be a list, possibly empty */
1966    if (!CONSP(FEATURES) && FEATURES != NIL)
1967	READ_ERROR1("%s is not a list", STROBJ(FEATURES));
1968
1969    status = LispEvalFeature(feature);
1970
1971    if (with) {
1972	if (status == T)
1973	    return (LispDoRead(info));
1974
1975	/* need to use the field discard because the following expression
1976	 * may be #.FORM or #,FORM or any other form that may generate
1977	 * side effects */
1978	info->discard = 1;
1979	LispDoRead(info);
1980	info->discard = 0;
1981
1982	return (LispDoRead(info));
1983    }
1984
1985    if (status == NIL)
1986	return (LispDoRead(info));
1987
1988    info->discard = 1;
1989    LispDoRead(info);
1990    info->discard = 0;
1991
1992    return (LispDoRead(info));
1993}
1994
1995/*
1996 * A very simple eval loop with AND, NOT, and OR functions for testing
1997 * the available features.
1998 */
1999static LispObj *
2000LispEvalFeature(LispObj *feature)
2001{
2002    READ_ENTER();
2003    Atom_id test;
2004    LispObj *object;
2005
2006    if (CONSP(feature)) {
2007	LispObj *function = CAR(feature), *arguments = CDR(feature);
2008
2009	if (!SYMBOLP(function))
2010	    READ_ERROR1("bad feature test function %s", STROBJ(function));
2011	if (!CONSP(arguments))
2012	    READ_ERROR1("bad feature test arguments %s", STROBJ(arguments));
2013	test = ATOMID(function);
2014	if (test == Sand) {
2015	    for (; CONSP(arguments); arguments = CDR(arguments)) {
2016		if (LispEvalFeature(CAR(arguments)) == NIL)
2017		    return (NIL);
2018	    }
2019	    return (T);
2020	}
2021	else if (test == Sor) {
2022	    for (; CONSP(arguments); arguments = CDR(arguments)) {
2023		if (LispEvalFeature(CAR(arguments)) == T)
2024		    return (T);
2025	    }
2026	    return (NIL);
2027	}
2028	else if (test == Snot) {
2029	    if (CONSP(CDR(arguments)))
2030		READ_ERROR0("too many arguments to NOT");
2031
2032	    return (LispEvalFeature(CAR(arguments)) == NIL ? T : NIL);
2033	}
2034	else
2035	    READ_ERROR1("unimplemented feature test function %s", test);
2036    }
2037
2038    if (KEYWORDP(feature))
2039	feature = feature->data.quote;
2040    else if (!SYMBOLP(feature))
2041	READ_ERROR1("bad feature specification %s", STROBJ(feature));
2042
2043    test = ATOMID(feature);
2044
2045    for (object = FEATURES; CONSP(object); object = CDR(object)) {
2046	/* paranoia check, elements in the feature list must ge keywords */
2047	if (!KEYWORDP(CAR(object)))
2048	    READ_ERROR1("%s is not a keyword", STROBJ(CAR(object)));
2049	if (ATOMID(CAR(object)) == test)
2050	    return (T);
2051    }
2052
2053    /* unknown feature */
2054    return (NIL);
2055}
2056