xref: /xsrc/external/mit/xedit/dist/lisp/read.c

/*
 * 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/read.c,v 1.36tsi Exp $ */

#include <errno.h>
#include "lisp/read.h"
#include "lisp/package.h"
#include "lisp/write.h"
#include <fcntl.h>
#include <stdarg.h>

/* This should be visible only in read.c, but if an error is generated,
 * the current code in write.c will print it as #<ERROR> */
#define LABEL_BIT_COUNT		8
#define LABEL_BIT_MASK		0xff
#define MAX_LABEL_VALUE		((1L << (sizeof(long) * 8 - 9)) - 1)
#define READLABEL(label)						\
    (LispObj*)(((label) << LABEL_BIT_COUNT) | READLABEL_MASK)
#define READLABELP(object)						\
    (((unsigned long)(object) & LABEL_BIT_MASK) == READLABEL_MASK)
#define READLABEL_VALUE(object)						\
    ((long)(object) >> LABEL_BIT_COUNT)

#define READ_ENTER()							\
    LispObj *read__stream = SINPUT;					\
    int read__line = LispGetLine(read__stream)
#define READ_ERROR0(format)						\
    LispReadError(read__stream, read__line, format)
#define READ_ERROR1(format, arg1)					\
    LispReadError(read__stream, read__line, format, arg1)
#define READ_ERROR2(format, arg1, arg2)					\
    LispReadError(read__stream, read__line, format, arg1, arg2)

#define READ_ERROR_EOF()	READ_ERROR0("unexpected end of input")
#define READ_ERROR_FIXNUM()	READ_ERROR0("number is not a fixnum")
#define READ_ERROR_INVARG()	READ_ERROR0("invalid argument")

#ifdef __UNIXOS2__
# define finite(x) isfinite(x)
#endif

/*
 * Types
 */
typedef struct _object_info {
    long label;		/* the read label of this object */
    LispObj *object;	/* the resulting object */
    long num_circles;	/* references to object before it was completely read */
} object_info;

typedef struct _read_info {
    int level;		/* level of open parentheses */

    int nodot;		/* flag set when reading a "special" list */

    int discard;	/* flag used when reading an unavailable feature */

    long circle_count;	/* if non zero, must resolve some labels */

    /* information for #<number>= and #<number># */
    object_info *objects;
    long num_objects;

    /* could use only the objects field as all circular data is known,
     * but check every object so that circular/shared references generated
     * by evaluations would not cause an infinite loop at read time */
    LispObj **circles;
    long num_circles;
} read_info;

/*
 * Protypes
 */
static LispObj *LispReadChar(LispBuiltin*, int);

static int LispGetLine(LispObj*);
#ifdef __GNUC__
#define PRINTF_FORMAT	__attribute__ ((format (printf, 3, 4)))
#else
#define PRINTF_FORMAT	/**/
#endif
static void LispReadError(LispObj*, int, const char*, ...);
#undef PRINTF_FORMAT
static void LispReadFixCircle(LispObj*, read_info*);
static LispObj *LispReadLabelCircle(LispObj*, read_info*);
static int LispReadCheckCircle(LispObj*, read_info*);
static LispObj *LispDoRead(read_info*);
static int LispSkipWhiteSpace(void);
static LispObj *LispReadList(read_info*);
static LispObj *LispReadQuote(read_info*);
static LispObj *LispReadBackquote(read_info*);
static LispObj *LispReadCommaquote(read_info*);
static LispObj *LispReadObject(int, read_info*);
static LispObj *LispParseAtom(char*, char*, int, int, LispObj*, int);
static LispObj *LispParseNumber(char*, int, LispObj*, int);
static int StringInRadix(char*, int, int);
static int AtomSeparator(int, int, int);
static LispObj *LispReadVector(read_info*);
static LispObj *LispReadMacro(read_info*);
static LispObj *LispReadFunction(read_info*);
static LispObj *LispReadRational(int, read_info*);
static LispObj *LispReadCharacter(read_info*);
static void LispSkipComment(void);
static LispObj *LispReadEval(read_info*);
static LispObj *LispReadComplex(read_info*);
static LispObj *LispReadPathname(read_info*);
static LispObj *LispReadStruct(read_info*);
static LispObj *LispReadMacroArg(read_info*);
static LispObj *LispReadArray(long, read_info*);
static LispObj *LispReadFeature(int, read_info*);
static LispObj *LispEvalFeature(LispObj*);

/*
 * Initialization
 */
static const char * const Char_Nul[] = {"Null", "Nul", NULL};
static const char * const Char_Soh[] = {"Soh", NULL};
static const char * const Char_Stx[] = {"Stx", NULL};
static const char * const Char_Etx[] = {"Etx", NULL};
static const char * const Char_Eot[] = {"Eot", NULL};
static const char * const Char_Enq[] = {"Enq", NULL};
static const char * const Char_Ack[] = {"Ack", NULL};
static const char * const Char_Bel[] = {"Bell", "Bel", NULL};
static const char * const Char_Bs[]  = {"Backspace", "Bs", NULL};
static const char * const Char_Tab[] = {"Tab", NULL};
static const char * const Char_Nl[]  = {"Newline", "Nl", "Lf", "Linefeed", NULL};
static const char * const Char_Vt[]  = {"Vt", NULL};
static const char * const Char_Np[]  = {"Page", "Np", NULL};
static const char * const Char_Cr[]  = {"Return", "Cr", NULL};
static const char * const Char_Ff[]  = {"So", "Ff", NULL};
static const char * const Char_Si[]  = {"Si", NULL};
static const char * const Char_Dle[] = {"Dle", NULL};
static const char * const Char_Dc1[] = {"Dc1", NULL};
static const char * const Char_Dc2[] = {"Dc2", NULL};
static const char * const Char_Dc3[] = {"Dc3", NULL};
static const char * const Char_Dc4[] = {"Dc4", NULL};
static const char * const Char_Nak[] = {"Nak", NULL};
static const char * const Char_Syn[] = {"Syn", NULL};
static const char * const Char_Etb[] = {"Etb", NULL};
static const char * const Char_Can[] = {"Can", NULL};
static const char * const Char_Em[]  = {"Em", NULL};
static const char * const Char_Sub[] = {"Sub", NULL};
static const char * const Char_Esc[] = {"Escape", "Esc", NULL};
static const char * const Char_Fs[]  = {"Fs", NULL};
static const char * const Char_Gs[]  = {"Gs", NULL};
static const char * const Char_Rs[]  = {"Rs", NULL};
static const char * const Char_Us[]  = {"Us", NULL};
static const char * const Char_Sp[]  = {"Space", "Sp", NULL};
static const char * const Char_Del[] = {"Rubout", "Del", "Delete", NULL};

const LispCharInfo LispChars[256] = {
    {Char_Nul},
    {Char_Soh},
    {Char_Stx},
    {Char_Etx},
    {Char_Eot},
    {Char_Enq},
    {Char_Ack},
    {Char_Bel},
    {Char_Bs},
    {Char_Tab},
    {Char_Nl},
    {Char_Vt},
    {Char_Np},
    {Char_Cr},
    {Char_Ff},
    {Char_Si},
    {Char_Dle},
    {Char_Dc1},
    {Char_Dc2},
    {Char_Dc3},
    {Char_Dc4},
    {Char_Nak},
    {Char_Syn},
    {Char_Etb},
    {Char_Can},
    {Char_Em},
    {Char_Sub},
    {Char_Esc},
    {Char_Fs},
    {Char_Gs},
    {Char_Rs},
    {Char_Us},
    {Char_Sp},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {Char_Del},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL},
    {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}

};

Atom_id Sand, Sor, Snot;


/*
 * Implementation
 */
LispObj *
Lisp_Read(LispBuiltin *builtin)
/*
 read &optional input-stream eof-error-p eof-value recursive-p
 */
{
    LispObj *result;

    LispObj *input_stream, *eof_error_p, *eof_value;

    eof_value = ARGUMENT(2);
    eof_error_p = ARGUMENT(1);
    input_stream = ARGUMENT(0);

    if (input_stream == UNSPEC)
	input_stream = NIL;
    else if (input_stream != NIL) {
	CHECK_STREAM(input_stream);
	else if (!input_stream->data.stream.readable)
	    LispDestroy("%s: stream %s is not readable",
			STRFUN(builtin), STROBJ(input_stream));
	LispPushInput(input_stream);
    }
    else if (CONSP(lisp__data.input_list)) {
	input_stream = STANDARD_INPUT;
	LispPushInput(input_stream);
    }

    if (eof_value == UNSPEC)
	eof_value = NIL;

    result = LispRead();
    if (input_stream != NIL)
	LispPopInput(input_stream);

    if (result == NULL) {
	if (eof_error_p != NIL)
	    LispDestroy("%s: EOF reading stream %s",
			STRFUN(builtin), STROBJ(input_stream));
	else
	    result = eof_value;
    }

    return (result);
}

static LispObj *
LispReadChar(LispBuiltin *builtin, int nohang)
{
    int character;

    LispObj *input_stream, *eof_error_p, *eof_value;

    eof_value = ARGUMENT(2);
    eof_error_p = ARGUMENT(1);
    input_stream = ARGUMENT(0);

    if (input_stream == UNSPEC)
	input_stream = NIL;
    else if (input_stream != NIL) {
	CHECK_STREAM(input_stream);
    }
    else
	input_stream = lisp__data.input;

    if (eof_value == UNSPEC)
	eof_value = NIL;

    character = EOF;

    if (input_stream->data.stream.readable) {
	LispFile *file = NULL;

	switch (input_stream->data.stream.type) {
	    case LispStreamStandard:
	    case LispStreamFile:
		file = FSTREAMP(input_stream);
		break;
	    case LispStreamPipe:
		file = IPSTREAMP(input_stream);
		break;
	    case LispStreamString:
		character = LispSgetc(SSTREAMP(input_stream));
		break;
	    default:
		break;
	}
	if (file != NULL) {
	    if (file->available || file->offset < file->length)
		character = LispFgetc(file);
	    else {
		if (nohang && !file->nonblock) {
		    if (fcntl(file->descriptor, F_SETFL, O_NONBLOCK) < 0)
			LispDestroy("%s: fcntl(%d): %s",
				    STRFUN(builtin), file->descriptor,
				    strerror(errno));
		    file->nonblock = 1;
		}
		else if (!nohang && file->nonblock) {
		    if (fcntl(file->descriptor, F_SETFL, 0) < 0)
			LispDestroy("%s: fcntl(%d): %s",
				    STRFUN(builtin), file->descriptor,
				    strerror(errno));
		    file->nonblock = 0;
		}
		if (nohang) {
		    unsigned char ch;

		    if (read(file->descriptor, &ch, 1) == 1)
			character = ch;
		    else if (errno == EAGAIN)
			return (NIL);	/* XXX no character available */
		    else
			character = EOF;
		}
		else
		    character = LispFgetc(file);
	    }
	}
    }
    else
	LispDestroy("%s: stream %s is unreadable",
		    STRFUN(builtin), STROBJ(input_stream));

    if (character == EOF) {
	if (eof_error_p != NIL)
	    LispDestroy("%s: EOF reading stream %s",
			STRFUN(builtin), STROBJ(input_stream));

	return (eof_value);
    }

    return (SCHAR(character));
}

LispObj *
Lisp_ReadChar(LispBuiltin *builtin)
/*
 read-char &optional input-stream eof-error-p eof-value recursive-p
 */
{
    return (LispReadChar(builtin, 0));
}

LispObj *
Lisp_ReadCharNoHang(LispBuiltin *builtin)
/*
 read-char-no-hang &optional input-stream eof-error-p eof-value recursive-p
 */
{
    return (LispReadChar(builtin, 1));
}

LispObj *
Lisp_ReadLine(LispBuiltin *builtin)
/*
 read-line &optional input-stream eof-error-p eof-value recursive-p
 */
{
    char *string;
    int ch, length;
    LispObj *result, *status = NIL;

    LispObj *input_stream, *eof_error_p, *eof_value;

    eof_value = ARGUMENT(2);
    eof_error_p = ARGUMENT(1);
    input_stream = ARGUMENT(0);

    if (input_stream == UNSPEC)
	input_stream = NIL;
    else if (input_stream == NIL)
	input_stream = STANDARD_INPUT;
    else {
	CHECK_STREAM(input_stream);
    }

    if (eof_value == UNSPEC)
	eof_value = NIL;

    result = NIL;
    string = NULL;
    length = 0;

    if (!input_stream->data.stream.readable)
	LispDestroy("%s: stream %s is unreadable",
		    STRFUN(builtin), STROBJ(input_stream));
    if (input_stream->data.stream.type == LispStreamString) {
	char *start, *end, *ptr;

	if (SSTREAMP(input_stream)->input >=
	    SSTREAMP(input_stream)->length) {
	    if (eof_error_p != NIL)
		LispDestroy("%s: EOS found reading %s",
			    STRFUN(builtin), STROBJ(input_stream));

	    status = T;
	    result = eof_value;
	    goto read_line_done;
	}

	start = SSTREAMP(input_stream)->string +
		SSTREAMP(input_stream)->input;
	end = SSTREAMP(input_stream)->string +
	      SSTREAMP(input_stream)->length;
	/* Search for a newline */
	for (ptr = start; *ptr != '\n' && ptr < end; ptr++)
	    ;
	if (ptr == end)
	    status = T;
	else if (!SSTREAMP(input_stream)->binary)
	    ++SSTREAMP(input_stream)->line;
	length = ptr - start;
	string = LispMalloc(length + 1);
	memcpy(string, start, length);
	string[length] = '\0';
	result = LSTRING2(string, length);
	/* macro LSTRING2 does not make a copy of it's arguments, and
	 * calls LispMused on it. */
	SSTREAMP(input_stream)->input += length + (status == NIL);
    }
    else /*if (input_stream->data.stream.type == LispStreamFile ||
	     input_stream->data.stream.type == LispStreamStandard ||
	     input_stream->data.stream.type == LispStreamPipe)*/ {
	LispFile *file;

	if (input_stream->data.stream.type == LispStreamPipe)
	    file = IPSTREAMP(input_stream);
	else
	    file = FSTREAMP(input_stream);

	if (file->nonblock) {
	    if (fcntl(file->descriptor, F_SETFL, 0) < 0)
		LispDestroy("%s: fcntl: %s",
			    STRFUN(builtin), strerror(errno));
	    file->nonblock = 0;
	}

	while (1) {
	    ch = LispFgetc(file);
	    if (ch == EOF) {
		if (length)
		    break;
		if (eof_error_p != NIL)
		    LispDestroy("%s: EOF found reading %s",
				STRFUN(builtin), STROBJ(input_stream));
		if (string)
		    LispFree(string);

		status = T;
		result = eof_value;
		goto read_line_done;
	    }
	    else if (ch == '\n')
		break;
	    else if ((length % 64) == 0)
		string = LispRealloc(string, length + 64);
	    string[length++] = ch;
	}
	if (string) {
	    if ((length % 64) == 0)
		string = LispRealloc(string, length + 1);
	    string[length] = '\0';
	    result = LSTRING2(string, length);
	}
	else
	    result = STRING("");
    }

read_line_done:
    RETURN(0) = status;
    RETURN_COUNT = 1;

    return (result);
}

LispObj *
LispRead(void)
{
    READ_ENTER();
    read_info info;
    LispObj *result, *code = COD;

    info.level = info.nodot = info.discard = 0;
    info.circle_count = 0;
    info.objects = NULL;
    info.num_objects = 0;

    result = LispDoRead(&info);

    /* fix circular/shared lists, note that this is done when returning to
     * the toplevel, so, if some circular/shared reference was evaluated,
     * it should have generated an expected error */
    if (info.num_objects) {
	if (info.circle_count) {
	    info.circles = NULL;
	    info.num_circles = 0;
	    LispReadFixCircle(result, &info);
	    if (info.num_circles)
		LispFree(info.circles);
	}
	LispFree(info.objects);
    }

    if (result == EOLIST)
	READ_ERROR0("object cannot start with #\\)");
    else if (result == DOT)
	READ_ERROR0("dot allowed only on lists");

    if (result != NULL && POINTERP(result)) {
	if (code == NIL)
	    COD = result;
	else
	    COD = CONS(COD, result);
    }

    return (result);
}

static int
LispGetLine(LispObj *stream)
{
    int line = -1;

    if (STREAMP(stream)) {
	switch (stream->data.stream.type) {
	    case LispStreamStandard:
	    case LispStreamFile:
		if (!FSTREAMP(stream)->binary)
		    line = FSTREAMP(stream)->line;
		break;
	    case LispStreamPipe:
		if (!IPSTREAMP(stream)->binary)
		    line = IPSTREAMP(stream)->line;
		break;
	    case LispStreamString:
		if (!SSTREAMP(stream)->binary)
		    line = SSTREAMP(stream)->line;
		break;
	    default:
		break;
	}
    }
    else if (stream == NIL && !Stdin->binary)
	line = Stdin->line;

    return (line);
}

static void
LispReadError(LispObj *stream, int line, const char *fmt, ...)
{
    char string[128];
    const char *buffer_string;
    LispObj *buffer = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
    int length;
    va_list ap;

    va_start(ap, fmt);
    vsnprintf(string, sizeof(string), fmt, ap);
    va_end(ap);

    LispFwrite(Stderr, "*** Reading ", 12);
    LispWriteObject(buffer, stream);
    buffer_string = LispGetSstring(SSTREAMP(buffer), &length);
    LispFwrite(Stderr, buffer_string, length);
    LispFwrite(Stderr, " at line ", 9);
    if (line < 0)
	LispFwrite(Stderr, "?\n", 2);
    else {
	char str[32];

	sprintf(str, "%d\n", line);
	LispFputs(Stderr, str);
    }

    LispDestroy("READ: %s", string);
}

static void
LispReadFixCircle(LispObj *object, read_info *info)
{
    LispObj *cons;

fix_again:
    switch (OBJECT_TYPE(object)) {
	case LispCons_t:
	    for (cons = object;
		 CONSP(object);
		 cons = object, object = CDR(object)) {
		if (READLABELP(CAR(object)))
		    CAR(object) = LispReadLabelCircle(CAR(object), info);
		else if (LispReadCheckCircle(object, info))
		    return;
		else
		    LispReadFixCircle(CAR(object), info);
	    }
	    if (READLABELP(object))
		CDR(cons) = LispReadLabelCircle(object, info);
	    else
		goto fix_again;
	    break;
	case LispArray_t:
	    if (READLABELP(object->data.array.list))
		object->data.array.list =
		    LispReadLabelCircle(object->data.array.list, info);
	    else if (!LispReadCheckCircle(object, info)) {
		object = object->data.array.list;
		goto fix_again;
	    }
	    break;
	case LispStruct_t:
	    if (READLABELP(object->data.struc.fields))
		object->data.struc.fields =
		    LispReadLabelCircle(object->data.struc.fields, info);
	    else if (!LispReadCheckCircle(object, info)) {
		object = object->data.struc.fields;
		goto fix_again;
	    }
	    break;
	case LispQuote_t:
	case LispBackquote_t:
	case LispFunctionQuote_t:
	    if (READLABELP(object->data.quote))
		object->data.quote =
		    LispReadLabelCircle(object->data.quote, info);
	    else {
		object = object->data.quote;
		goto fix_again;
	    }
	    break;
	case LispComma_t:
	    if (READLABELP(object->data.comma.eval))
		object->data.comma.eval =
		    LispReadLabelCircle(object->data.comma.eval, info);
	    else {
		object = object->data.comma.eval;
		goto fix_again;
	    }
	    break;
	case LispLambda_t:
	    if (READLABELP(object->data.lambda.code))
		object->data.lambda.code =
		    LispReadLabelCircle(object->data.lambda.code, info);
	    else if (!LispReadCheckCircle(object, info)) {
		object = object->data.lambda.code;
		goto fix_again;
	    }
	    break;
	default:
	    break;
    }
}

static LispObj *
LispReadLabelCircle(LispObj *label, read_info *info)
{
    long i, value = READLABEL_VALUE(label);

    for (i = 0; i < info->num_objects; i++)
	if (info->objects[i].label == value)
	    return (info->objects[i].object);

    LispDestroy("READ: internal error");
    /*NOTREACHED*/
    return (label);
}

static int
LispReadCheckCircle(LispObj *object, read_info *info)
{
    long i;

    for (i = 0; i < info->num_circles; i++)
	if (info->circles[i] == object)
	    return (1);

    if ((info->num_circles % 16) == 0)
	info->circles = LispRealloc(info->circles, sizeof(LispObj*) *
				    (info->num_circles + 16));
    info->circles[info->num_circles++] = object;

    return (0);
}

static LispObj *
LispDoRead(read_info *info)
{
    LispObj *object;
    int ch = LispSkipWhiteSpace();

    switch (ch) {
	case '(':
	    object = LispReadList(info);
	    break;
	case ')':
	    for (ch = LispGet(); ch != EOF && ch != '\n'; ch = LispGet()) {
		if (!isspace(ch)) {
		    LispUnget(ch);
		    break;
		}
	    }
	    return (EOLIST);
	case EOF:
	    return (NULL);
	case '\'':
	    object = LispReadQuote(info);
	    break;
	case '`':
	    object = LispReadBackquote(info);
	    break;
	case ',':
	    object = LispReadCommaquote(info);
	    break;
	case '#':
	    object = LispReadMacro(info);
	    break;
	default:
	    LispUnget(ch);
	    object = LispReadObject(0, info);
	    break;
    }

    return (object);
}

static LispObj *
LispReadMacro(read_info *info)
{
    READ_ENTER();
    LispObj *result = NULL;
    int ch = LispGet();

    switch (ch) {
	case '(':
	    result = LispReadVector(info);
	    break;
	case '\'':
	   result = LispReadFunction(info);
	   break;
	case 'b':
	case 'B':
	    result = LispReadRational(2, info);
	    break;
	case 'o':
	case 'O':
	    result = LispReadRational(8, info);
	    break;
	case 'x':
	case 'X':
	    result = LispReadRational(16, info);
	    break;
	case '\\':
	    result = LispReadCharacter(info);
	    break;
	case '|':
	    LispSkipComment();
	    result = LispDoRead(info);
	    break;
	case '.':	/* eval when compiling */
	case ',':	/* eval when loading */
	    result = LispReadEval(info);
	    break;
	case 'c':
	case 'C':
	    result = LispReadComplex(info);
	    break;
	case 'p':
	case 'P':
	    result = LispReadPathname(info);
	    break;
	case 's':
	case 'S':
	    result = LispReadStruct(info);
	    break;
	case '+':
	    result = LispReadFeature(1, info);
	    break;
	case '-':
	    result = LispReadFeature(0, info);
	    break;
	case ':':
	    /* Uninterned symbol */
	    result = LispReadObject(1, info);
	    break;
	default:
	    if (isdigit(ch)) {
		LispUnget(ch);
		result = LispReadMacroArg(info);
	    }
	    else if (!info->discard)
		READ_ERROR1("undefined dispatch macro character #%c", ch);
	    break;
    }

    return (result);
}

static LispObj *
LispReadMacroArg(read_info *info)
{
    READ_ENTER();
    LispObj *result = NIL;
    long i, integer;
    int ch;

    /* skip leading zeros */
    while (ch = LispGet(), ch != EOF && isdigit(ch) && ch == '0')
	;

    if (ch == EOF)
	READ_ERROR_EOF();

    /* if ch is not a number the argument was zero */
    if (isdigit(ch)) {
	char stk[32], *str;
	int len = 1;

	stk[0] = ch;
	for (;;) {
	    ch = LispGet();
	    if (!isdigit(ch))
		break;
	    if (len + 1 >= sizeof(stk))
		READ_ERROR_FIXNUM();
	    stk[len++] = ch;
	}
	stk[len] = '\0';
	errno = 0;
	integer = strtol(stk, &str, 10);
	/* number is positive because sign is not processed here */
	if (*str || errno == ERANGE || integer > MOST_POSITIVE_FIXNUM)
	    READ_ERROR_FIXNUM();
    }
    else
	integer = 0;

    switch (ch) {
	case 'a':
	case 'A':
	    if (integer == 1) {
		/* LispReadArray and LispReadList expect
		 * the '(' being already read  */
		if ((ch = LispSkipWhiteSpace()) != '(') {
		    if (info->discard)
			return (ch == EOF ? NULL : NIL);
		    READ_ERROR0("bad array specification");
		}
		result = LispReadVector(info);
	    }
	    else
		result = LispReadArray(integer, info);
	    break;
	case 'r':
	case 'R':
	    result = LispReadRational(integer, info);
	    break;
	case '=':
	    if (integer > MAX_LABEL_VALUE)
		READ_ERROR_FIXNUM();
	    if (!info->discard) {
		long num_objects = info->num_objects;

		/* check for duplicated label */
		for (i = 0; i < info->num_objects; i++) {
		    if (info->objects[i].label == integer)
			READ_ERROR1("label #%ld# defined more than once",
				    integer);
		}
		info->objects = LispRealloc(info->objects,
					    sizeof(object_info) *
					    (num_objects + 1));
		/* if this label is referenced it is a shared/circular object */
		info->objects[num_objects].label = integer;
		info->objects[num_objects].object = NULL;
		info->objects[num_objects].num_circles = 0;
		++info->num_objects;
		result = LispDoRead(info);
		if (READLABELP(result) && READLABEL_VALUE(result) == integer)
		    READ_ERROR2("incorrect syntax #%ld= #%ld#",
				integer, integer);
		/* any reference to it now is not shared/circular */
		info->objects[num_objects].object = result;
	    }
	    else
		result = LispDoRead(info);
	    break;
	case '#':
	    if (integer > MAX_LABEL_VALUE)
		READ_ERROR_FIXNUM();
	    if (!info->discard) {
		/* search object */
		for (i = 0; i < info->num_objects; i++) {
		    if (info->objects[i].label == integer) {
			result = info->objects[i].object;
			if (result == NULL) {
			    ++info->objects[i].num_circles;
			    ++info->circle_count;
			    result = READLABEL(integer);
			}
			break;
		    }
		}
		if (i == info->num_objects)
		    READ_ERROR1("undefined label #%ld#", integer);
	    }
	    break;
	default:
	    if (!info->discard)
		READ_ERROR1("undefined dispatch macro character #%c", ch);
	    break;
    }

    return (result);
}

static int
LispSkipWhiteSpace(void)
{
    int ch;

    for (;;) {
	while (ch = LispGet(), isspace(ch) && ch != EOF)
	    ;
	if (ch == ';') {
	    while (ch = LispGet(), ch != '\n' && ch != EOF)
		;
	    if (ch == EOF)
		return (EOF);
	}
	else
	    break;
    }

    return (ch);
}

/* any data in the format '(' FORM ')' is read here */
static LispObj *
LispReadList(read_info *info)
{
    READ_ENTER();
    GC_ENTER();
    LispObj *result, *cons, *object;
    int dot = 0;

    ++info->level;
    /* check for () */
    object = LispDoRead(info);
    if (object == EOLIST) {
	--info->level;

	return (NIL);
    }

    if (object == DOT)
	READ_ERROR0("illegal start of dotted list");

    result = cons = CONS(object, NIL);

    /* make sure GC will not release data being read */
    GC_PROTECT(result);

    while ((object = LispDoRead(info)) != EOLIST) {
	if (object == NULL)
	    READ_ERROR_EOF();
	if (object == DOT) {
	    if (info->nodot == info->level)
		READ_ERROR0("dotted list not allowed");
	    /* this is a dotted list */
	    if (dot)
		READ_ERROR0("more than one . in list");
	    dot = 1;
	}
	else {
	    if (dot) {
		/* only one object after a dot */
		if (++dot > 2)
		    READ_ERROR0("more than one object after . in list");
		RPLACD(cons, object);
	    }
	    else {
		RPLACD(cons, CONS(object, NIL));
		cons = CDR(cons);
	    }
	}
    }

    /* this will happen if last list element was a dot */
    if (dot == 1)
	READ_ERROR0("illegal end of dotted list");

    --info->level;
    GC_LEAVE();

    return (result);
}

static LispObj *
LispReadQuote(read_info *info)
{
    READ_ENTER();
    LispObj *quote = LispDoRead(info), *result;

    if (INVALIDP(quote))
	READ_ERROR_INVARG();

    result = QUOTE(quote);

    return (result);
}

static LispObj *
LispReadBackquote(read_info *info)
{
    READ_ENTER();
    LispObj *backquote = LispDoRead(info), *result;

    if (INVALIDP(backquote))
	READ_ERROR_INVARG();

    result = BACKQUOTE(backquote);

    return (result);
}

static LispObj *
LispReadCommaquote(read_info *info)
{
    READ_ENTER();
    LispObj *comma, *result;
    int atlist = LispGet();

    if (atlist == EOF)
	READ_ERROR_EOF();
    else if (atlist != '@' && atlist != '.')
	LispUnget(atlist);

    comma = LispDoRead(info);
    if (comma == DOT) {
	atlist = '@';
	comma = LispDoRead(info);
    }
    if (INVALIDP(comma))
	READ_ERROR_INVARG();

    result = COMMA(comma, atlist == '@' || atlist == '.');

    return (result);
}

/*
 * Read anything that is not readily identifiable by it's first character
 * and also put the code for reading atoms, numbers and strings together.
 */
static LispObj *
LispReadObject(int unintern, read_info *info)
{
    READ_ENTER();
    LispObj *object;
    char stk[128], *string, *package, *symbol;
    int ch, length, backslash, size, quote, unreadable, collon;

    package = symbol = string = stk;
    size = sizeof(stk);
    backslash = quote = unreadable = collon = 0;
    length = 0;

    ch = LispGet();
    if (unintern && (ch == ':' || ch == '"'))
	READ_ERROR0("syntax error after #:");
    else if (ch == '"' || ch == '|')
	quote = ch;
    else if (ch == '\\') {
	unreadable = backslash = 1;
	string[length++] = ch;
    }
    else if (ch == ':') {
	collon = 1;
	string[length++] = ch;
	symbol = string + 1;
	ch = LispGet();
	if (ch == '|') {
	    quote = ch;
	    unreadable = 1;
	}
	else if (ch != EOF)
	    LispUnget(ch);
    }
    else if (ch) {
	if (islower(ch))
	    ch = toupper(ch);
	string[length++] = ch;
    }
    else
	unreadable = 1;

    /* read remaining data */
    for (; ch;) {
	ch = LispGet();

	if (ch == EOF) {
	    if (quote) {
		/* if quote, file ended with an open quoted object */
		if (string != stk)
		    LispFree(string);
		return (NULL);
	    }
	    break;
	}
	else if (ch == '\0')
	    break;

	if (ch == '\\') {
	    backslash = !backslash;
	    if (quote == '"') {
		/* only remove backslashs from strings */
		if (backslash)
		    continue;
	    }
	    else
		unreadable = 1;
	}
	else if (backslash)
	    backslash = 0;
	else if (ch == quote)
	    break;
	else if (!quote && !backslash) {
	    if (islower(ch))
		ch = toupper(ch);
	    else if (isspace(ch))
		break;
	    else if (AtomSeparator(ch, 0, 0)) {
		LispUnget(ch);
		break;
	    }
	    else if (ch == ':') {
		if (collon == 0 ||
		    (collon == (1 - unintern) && symbol == string + length)) {
		    ++collon;
		    symbol = string + length + 1;
		}
		else
		    READ_ERROR0("too many collons");
	    }
	}

	if (length + 2 >= size) {
	    if (string == stk) {
		size = 1024;
		string = LispMalloc(size);
		strcpy(string, stk);
	    }
	    else {
		size += 1024;
		string = LispRealloc(string, size);
	    }
	    symbol = string + (symbol - package);
	    package = string;
	}
	string[length++] = ch;
    }

    if (info->discard) {
	if (string != stk)
	    LispFree(string);

	return (ch == EOF ? NULL : NIL);
    }

    string[length] = '\0';

    if (unintern) {
	if (length == 0)
	    READ_ERROR0("syntax error after #:");
	object = UNINTERNED_ATOM(string);
    }

    else if (quote == '"')
	object = LSTRING(string, length);

    else if (collon) {
	/* Package specified in object name */
	symbol[-1] = '\0';
	if (collon > 1)
	    symbol[-2] = '\0';
	object = LispParseAtom(package, symbol,
			       collon == 2, unreadable,
			       read__stream, read__line);
    }

    else if (quote == '|' || (unreadable && !collon)) {
	/* Set unreadable field, this atom needs quoting to be read back */
	object = ATOM(string);
	object->data.atom->unreadable = 1;
    }

    /* Check some common symbols */
    else if (length == 1 && string[0] == 'T')
	/* The T */
	object = T;

    else if (length == 1 && string[0] == '.')
	/* The dot */
	object = DOT;

    else if (length == 3 &&
	     string[0] == 'N' && string[1] == 'I' && string[2] == 'L')
	/* The NIL */
	object = NIL;

    else if (isdigit(string[0]) || string[0] == '.' ||
	     ((string[0] == '-' || string[0] == '+') && string[1]))
	/* Looks like a number */
	object = LispParseNumber(string, 10, read__stream, read__line);

    else
	/* A normal atom */
	object = ATOM(string);

    if (string != stk)
	LispFree(string);

    return (object);
}

static LispObj *
LispParseAtom(char *package, char *symbol, int intern, int unreadable,
	      LispObj *read__stream, int read__line)
{
    LispObj *object = NULL, *thepackage = NULL;
    LispPackage *pack = NULL;

    if (!unreadable) {
	/* Until NIL and T be treated as normal symbols */
	if (symbol[0] == 'N' && symbol[1] == 'I' &&
	    symbol[2] == 'L' && symbol[3] == '\0')
	    return (NIL);
	if (symbol[0] == 'T' && symbol[1] == '\0')
	    return (T);
	unreadable = !LispCheckAtomString(symbol);
    }

    /* If package is empty, it is a keyword */
    if (package[0] == '\0') {
	thepackage = lisp__data.keyword;
	pack = lisp__data.key;
    }

    else {
	/* Else, search it in the package list */
	thepackage = LispFindPackageFromString(package);

	if (thepackage == NIL)
	    READ_ERROR1("the package %s is not available", package);

	pack = thepackage->data.package.package;
    }

    if (pack == lisp__data.pack && intern) {
	/* Redundant package specification, since requesting a
	 * intern symbol, create it if does not exist */

	object = ATOM(symbol);
	if (unreadable)
	    object->data.atom->unreadable = 1;
    }

    else if (intern || pack == lisp__data.key) {
	/* Symbol is created, or just fetched from the specified package */

	LispPackage *savepack;
	LispObj *savepackage = PACKAGE;

	/* Remember curent package */
	savepack = lisp__data.pack;

	/* Temporarily set another package */
	lisp__data.pack = pack;
	PACKAGE = thepackage;

	/* Get the object pointer */
	if (pack == lisp__data.key)
	    object = KEYWORD(LispDoGetAtom(symbol, 0)->key->value);
	else
	    object = ATOM(symbol);
	if (unreadable)
	    object->data.atom->unreadable = 1;

	/* Restore current package */
	lisp__data.pack = savepack;
	PACKAGE = savepackage;
    }

    else {
	/* Symbol must exist (and be extern) in the specified package */

	LispAtom *atom;

	atom = (LispAtom *)hash_check(pack->atoms, symbol, strlen(symbol));
	if (atom)
	    object = atom->object;

	/* No object found */
	if (object == NULL || object->data.atom->ext == 0)
	    READ_ERROR2("no extern symbol %s in package %s", symbol, package);
    }

    return (object);
}

static LispObj *
LispParseNumber(char *str, int radix, LispObj *read__stream, int read__line)
{
    int len;
    long integer;
    double dfloat;
    char *ratio, *ptr;
    LispObj *number;
    mpi *bignum;
    mpr *bigratio;

    if (radix < 2 || radix > 36)
	READ_ERROR1("radix %d is not in the range 2 to 36", radix);

    if (*str == '\0')
	return (NULL);

    ratio = strchr(str, '/');
    if (ratio) {
	/* check if looks like a correctly specified ratio */
	if (ratio[1] == '\0' || strchr(ratio + 1, '/') != NULL)
	    return (ATOM(str));

	/* ratio must point to an integer in radix base */
	*ratio++ = '\0';
    }
    else if (radix == 10) {
	int dot = 0;
	int type = 0;

	/* check if it is a floating point number */
	ptr = str;
	if (*ptr == '-' || *ptr == '+')
	    ++ptr;
	else if (*ptr == '.') {
	    dot = 1;
	    ++ptr;
	}
	while (*ptr) {
	    if (*ptr == '.') {
		if (dot)
		    return (ATOM(str));
		/* ignore it if last char is a dot */
		if (ptr[1] == '\0') {
		    *ptr = '\0';
		    break;
		}
		dot = 1;
	    }
	    else if (!isdigit(*ptr))
		break;
	    ++ptr;
	}

	switch (*ptr) {
	    case '\0':
		if (dot)		/* if dot, it is default float */
		    type = 'E';
		break;
	    case 'E': case 'S': case 'F': case 'D': case 'L':
		type = *ptr;
		*ptr = 'E';
		break;
	    default:
		return (ATOM(str));	/* syntax error */
	}

	/* if type set, it is not an integer specification */
	if (type) {
	    if (*ptr) {
		int itype = *ptr;
		char *ptype = ptr;

		++ptr;
		if (*ptr == '+' || *ptr == '-')
		    ++ptr;
		while (*ptr && isdigit(*ptr))
		    ++ptr;
		if (*ptr) {
		    *ptype = itype;

		    return (ATOM(str));
		}
	    }

	    dfloat = strtod(str, NULL);
	    if (!finite(dfloat))
		READ_ERROR0("floating point overflow");

	    return (DFLOAT(dfloat));
	}
    }

    /* check if correctly specified in the given radix */
    len = strlen(str) - 1;
    if (!ratio && radix != 10 && str[len] == '.')
	str[len] = '\0';

    if (ratio || radix != 10) {
	if (!StringInRadix(str, radix, 1)) {
	    if (ratio)
		ratio[-1] = '/';
	    return (ATOM(str));
	}
	if (ratio && !StringInRadix(ratio, radix, 0)) {
	    ratio[-1] = '/';
	    return (ATOM(str));
	}
    }

    bignum = NULL;
    bigratio = NULL;

    errno = 0;
    integer = strtol(str, NULL, radix);

    /* if does not fit in a long */
    if (errno == ERANGE) {
	bignum = LispMalloc(sizeof(mpi));
	mpi_init(bignum);
	mpi_setstr(bignum, str, radix);
    }


    if (ratio && integer != 0) {
	long denominator;

	errno = 0;
	denominator = strtol(ratio, NULL, radix);
	if (denominator == 0)
	    READ_ERROR0("divide by zero");

	if (bignum == NULL) {
	    if (integer == MINSLONG ||
		(denominator == LONG_MAX && errno == ERANGE)) {
		bigratio = LispMalloc(sizeof(mpr));
		mpr_init(bigratio);
		mpi_seti(mpr_num(bigratio), integer);
		mpi_setstr(mpr_den(bigratio), ratio, radix);
	    }
	}
	else {
	    bigratio = LispMalloc(sizeof(mpr));
	    mpr_init(bigratio);
	    mpi_set(mpr_num(bigratio), bignum);
	    mpi_clear(bignum);
	    LispFree(bignum);
	    mpi_setstr(mpr_den(bigratio), ratio, radix);
	}

	if (bigratio) {
	    mpr_canonicalize(bigratio);
	    if (mpi_fiti(mpr_num(bigratio)) &&
		mpi_fiti(mpr_den(bigratio))) {
		integer = mpi_geti(mpr_num(bigratio));
		denominator = mpi_geti(mpr_den(bigratio));
		mpr_clear(bigratio);
		LispFree(bigratio);
		if (denominator == 1)
		    number = INTEGER(integer);
		else
		    number = RATIO(integer, denominator);
	    }
	    else
		number = BIGRATIO(bigratio);
	}
	else {
	    long num = integer, den = denominator, rest;

	    if (num < 0)
		num = -num;
	    for (;;) {
		if ((rest = den % num) == 0)
		    break;
		den = num;
		num = rest;
	    }
	    if (den != 1) {
		denominator /= num;
		integer /= num;
	    }
	    if (denominator < 0) {
		integer = -integer;
		denominator = -denominator;
	    }
	    if (denominator == 1)
		number = INTEGER(integer);
	    else
		number = RATIO(integer, denominator);
	}
    }
    else if (bignum)
	number = BIGNUM(bignum);
    else
	number = INTEGER(integer);

    return (number);
}

static int
StringInRadix(char *str, int radix, int skip_sign)
{
    if (skip_sign && (*str == '-' || *str == '+'))
	++str;
    while (*str) {
	if (*str >= '0' && *str <= '9') {
	    if (*str - '0' >= radix)
		return (0);
	}
	else if (*str >= 'A' && *str <= 'Z') {
	    if (radix <= 10 || *str - 'A' + 10 >= radix)
		return (0);
	}
	else
	    return (0);
	str++;
    }

    return (1);
}

static int
AtomSeparator(int ch, int check_space, int check_backslash)
{
    if (check_space && isspace(ch))
	return (1);
    if (check_backslash && ch == '\\')
	return (1);
    return (strchr("(),\";'`#|,", ch) != NULL);
}

static LispObj *
LispReadVector(read_info *info)
{
    LispObj *objects;
    int nodot = info->nodot;

    info->nodot = info->level + 1;
    objects = LispReadList(info);
    info->nodot = nodot;

    if (info->discard)
	return (objects);

    return (VECTOR(objects));
}

static LispObj *
LispReadFunction(read_info *info)
{
    READ_ENTER();
    int nodot = info->nodot;
    LispObj *function;

    info->nodot = info->level + 1;
    function = LispDoRead(info);
    info->nodot = nodot;

    if (info->discard)
	return (function);

    if (INVALIDP(function))
	READ_ERROR_INVARG();
    else if (CONSP(function)) {
	if (CAR(function) != Olambda)
	    READ_ERROR_INVARG();

	return (FUNCTION_QUOTE(function));
    }
    else if (!SYMBOLP(function))
	READ_ERROR_INVARG();

    return (FUNCTION_QUOTE(function));
}

static LispObj *
LispReadRational(int radix, read_info *info)
{
    READ_ENTER();
    LispObj *number;
    int ch, len, size;
    char stk[128], *str;

    len = 0;
    str = stk;
    size = sizeof(stk);

    for (;;) {
	ch = LispGet();
	if (ch == EOF || isspace(ch))
	    break;
	else if (AtomSeparator(ch, 0, 1)) {
	    LispUnget(ch);
	    break;
	}
	else if (islower(ch))
	    ch = toupper(ch);
	if ((ch < '0' || ch > '9') && (ch < 'A' || ch > 'Z') &&
	    ch != '+' && ch != '-' && ch != '/') {
	    if (str != stk)
		LispFree(str);
	    if (!info->discard)
		READ_ERROR1("bad character %c for rational number", ch);
	}
	if (len + 1 >= size) {
	    if (str == stk) {
		size = 512;
		str = LispMalloc(size);
		strcpy(str + 1, stk + 1);
	    }
	    else {
		size += 512;
		str = LispRealloc(str, size);
	    }
	}
	str[len++] = ch;
    }

    if (info->discard) {
	if (str != stk)
	    LispFree(str);

	return (ch == EOF ? NULL : NIL);
    }

    str[len] = '\0';

    number = LispParseNumber(str, radix, read__stream, read__line);
    if (str != stk)
	LispFree(str);

    if (!RATIONALP(number))
	READ_ERROR0("bad rational number specification");

    return (number);
}

static LispObj *
LispReadCharacter(read_info *info)
{
    READ_ENTER();
    long c;
    int ch, len;
    char stk[64];

    ch = LispGet();
    if (ch == EOF)
	return (NULL);

    stk[0] = ch;
    len = 1;

    for (;;) {
	ch = LispGet();
	if (ch == EOF)
	    break;
	else if (ch != '-' && !isalnum(ch)) {
	    LispUnget(ch);
	    break;
	}
	if (len + 1 < sizeof(stk))
	    stk[len++] = ch;
    }
    if (len > 1) {
	const char * const *names;
	int found = 0;
	stk[len] = '\0';

	for (c = ch = 0; ch <= ' ' && !found; ch++) {
	    for (names = LispChars[ch].names; *names; names++)
		if (strcasecmp(*names, stk) == 0) {
		    c = ch;
		    found = 1;
		    break;
		}
	}
	if (!found) {
	    for (names = LispChars[0177].names; *names; names++)
		if (strcasecmp(*names, stk) == 0) {
		    c = 0177;
		    found = 1;
		    break;
		}
	}

	if (!found) {
	    if (info->discard)
		return (NIL);
	    READ_ERROR1("unkwnown character %s", stk);
	}
    }
    else
	c = stk[0];

    return (SCHAR(c));
}

static void
LispSkipComment(void)
{
    READ_ENTER();
    int ch, comm = 1;

    for (;;) {
	ch = LispGet();
	if (ch == '#') {
	    ch = LispGet();
	    if (ch == '|')
		++comm;
	    continue;
	}
	while (ch == '|') {
	    ch = LispGet();
	    if (ch == '#' && --comm == 0)
		return;
	}
	if (ch == EOF)
	    READ_ERROR_EOF();
    }
}

static LispObj *
LispReadEval(read_info *info)
{
    READ_ENTER();
    int nodot = info->nodot;
    LispObj *code;

    info->nodot = info->level + 1;
    code = LispDoRead(info);
    info->nodot = nodot;

    if (info->discard)
	return (code);

    if (INVALIDP(code))
	READ_ERROR_INVARG();

    return (EVAL(code));
}

static LispObj *
LispReadComplex(read_info *info)
{
    READ_ENTER();
    GC_ENTER();
    int nodot = info->nodot;
    LispObj *number, *arguments;

    info->nodot = info->level + 1;
    arguments = LispDoRead(info);
    info->nodot = nodot;

    /* form read */
    if (info->discard)
	return (arguments);

    if (INVALIDP(arguments) || !CONSP(arguments))
	READ_ERROR_INVARG();

    GC_PROTECT(arguments);
    number = APPLY(Ocomplex, arguments);
    GC_LEAVE();

    return (number);
}

static LispObj *
LispReadPathname(read_info *info)
{
    READ_ENTER();
    GC_ENTER();
    int nodot = info->nodot;
    LispObj *path, *arguments;

    info->nodot = info->level + 1;
    arguments = LispDoRead(info);
    info->nodot = nodot;

    /* form read */
    if (info->discard)
	return (arguments);

    if (INVALIDP(arguments))
	READ_ERROR_INVARG();

    GC_PROTECT(arguments);
    path = APPLY1(Oparse_namestring, arguments);
    GC_LEAVE();

    return (path);
}

static LispObj *
LispReadStruct(read_info *info)
{
    READ_ENTER();
    GC_ENTER();
    int len, nodot = info->nodot;
    char stk[128], *str;
    LispObj *struc, *fields;

    info->nodot = info->level + 1;
    fields = LispDoRead(info);
    info->nodot = nodot;

    /* form read */
    if (info->discard)
	return (fields);

    if (INVALIDP(fields) || !CONSP(fields) || !SYMBOLP(CAR(fields)))
	READ_ERROR_INVARG();

    GC_PROTECT(fields);

    len = ATOMID(CAR(fields))->length;
	   /* MAKE- */
    if (len + 6 > sizeof(stk))
	str = LispMalloc(len + 6);
    else
	str = stk;
    sprintf(str, "MAKE-%s", ATOMID(CAR(fields))->value);
    RPLACA(fields, ATOM(str));
    if (str != stk)
	LispFree(str);
    struc = APPLY(Omake_struct, fields);
    GC_LEAVE();

    return (struc);
}

/* XXX This is broken, needs a rewritten as soon as true vector/arrays be
 * implemented. */
static LispObj *
LispReadArray(long dimensions, read_info *info)
{
    READ_ENTER();
    GC_ENTER();
    long count;
    int nodot = info->nodot;
    LispObj *arguments, *initial, *dim, *cons, *array, *data;

    info->nodot = info->level + 1;
    data = LispDoRead(info);
    info->nodot = nodot;

    /* form read */
    if (info->discard)
	return (data);

    if (INVALIDP(data))
	READ_ERROR_INVARG();

    initial = Kinitial_contents;

    dim = cons = NIL;
    if (dimensions) {
	LispObj *array;

	for (count = 0, array = data; count < dimensions; count++) {
	    long length;
	    LispObj *item;

	    if (!CONSP(array))
		READ_ERROR0("bad array for given dimension");
	    item = array;
	    array = CAR(array);

	    for (length = 0; CONSP(item); item = CDR(item), length++)
		;

	    if (dim == NIL) {
		dim = cons = CONS(FIXNUM(length), NIL);
		GC_PROTECT(dim);
	    }
	    else {
		RPLACD(cons, CONS(FIXNUM(length), NIL));
		cons = CDR(cons);
	    }
	}
    }

    arguments = CONS(dim, CONS(initial, CONS(data, NIL)));
    GC_PROTECT(arguments);
    array = APPLY(Omake_array, arguments);
    GC_LEAVE();

    return (array);
}

static LispObj *
LispReadFeature(int with, read_info *info)
{
    READ_ENTER();
    LispObj *status;
    LispObj *feature = LispDoRead(info);

    /* form read */
    if (info->discard)
	return (feature);

    if (INVALIDP(feature))
	READ_ERROR_INVARG();

    /* paranoia check, features must be a list, possibly empty */
    if (!CONSP(FEATURES) && FEATURES != NIL)
	READ_ERROR1("%s is not a list", STROBJ(FEATURES));

    status = LispEvalFeature(feature);

    if (with) {
	if (status == T)
	    return (LispDoRead(info));

	/* need to use the field discard because the following expression
	 * may be #.FORM or #,FORM or any other form that may generate
	 * side effects */
	info->discard = 1;
	LispDoRead(info);
	info->discard = 0;

	return (LispDoRead(info));
    }

    if (status == NIL)
	return (LispDoRead(info));

    info->discard = 1;
    LispDoRead(info);
    info->discard = 0;

    return (LispDoRead(info));
}

/*
 * A very simple eval loop with AND, NOT, and OR functions for testing
 * the available features.
 */
static LispObj *
LispEvalFeature(LispObj *feature)
{
    READ_ENTER();
    Atom_id test;
    LispObj *object;

    if (CONSP(feature)) {
	LispObj *function = CAR(feature), *arguments = CDR(feature);

	if (!SYMBOLP(function))
	    READ_ERROR1("bad feature test function %s", STROBJ(function));
	if (!CONSP(arguments))
	    READ_ERROR1("bad feature test arguments %s", STROBJ(arguments));
	test = ATOMID(function);
	if (test == Sand) {
	    for (; CONSP(arguments); arguments = CDR(arguments)) {
		if (LispEvalFeature(CAR(arguments)) == NIL)
		    return (NIL);
	    }
	    return (T);
	}
	else if (test == Sor) {
	    for (; CONSP(arguments); arguments = CDR(arguments)) {
		if (LispEvalFeature(CAR(arguments)) == T)
		    return (T);
	    }
	    return (NIL);
	}
	else if (test == Snot) {
	    if (CONSP(CDR(arguments)))
		READ_ERROR0("too many arguments to NOT");

	    return (LispEvalFeature(CAR(arguments)) == NIL ? T : NIL);
	}
	else
	    READ_ERROR1("unimplemented feature test function %s", test);
    }

    if (KEYWORDP(feature))
	feature = feature->data.quote;
    else if (!SYMBOLP(feature))
	READ_ERROR1("bad feature specification %s", STROBJ(feature));

    test = ATOMID(feature);

    for (object = FEATURES; CONSP(object); object = CDR(object)) {
	/* paranoia check, elements in the feature list must ge keywords */
	if (!KEYWORDP(CAR(object)))
	    READ_ERROR1("%s is not a keyword", STROBJ(CAR(object)));
	if (ATOMID(CAR(object)) == test)
	    return (T);
    }

    /* unknown feature */
    return (NIL);
}