2058 lines
47 KiB
C
2058 lines
47 KiB
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, 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 char *Char_Nul[] = {"Null", "Nul", NULL};
|
|
static char *Char_Soh[] = {"Soh", NULL};
|
|
static char *Char_Stx[] = {"Stx", NULL};
|
|
static char *Char_Etx[] = {"Etx", NULL};
|
|
static char *Char_Eot[] = {"Eot", NULL};
|
|
static char *Char_Enq[] = {"Enq", NULL};
|
|
static char *Char_Ack[] = {"Ack", NULL};
|
|
static char *Char_Bel[] = {"Bell", "Bel", NULL};
|
|
static char *Char_Bs[] = {"Backspace", "Bs", NULL};
|
|
static char *Char_Tab[] = {"Tab", NULL};
|
|
static char *Char_Nl[] = {"Newline", "Nl", "Lf", "Linefeed", NULL};
|
|
static char *Char_Vt[] = {"Vt", NULL};
|
|
static char *Char_Np[] = {"Page", "Np", NULL};
|
|
static char *Char_Cr[] = {"Return", "Cr", NULL};
|
|
static char *Char_Ff[] = {"So", "Ff", NULL};
|
|
static char *Char_Si[] = {"Si", NULL};
|
|
static char *Char_Dle[] = {"Dle", NULL};
|
|
static char *Char_Dc1[] = {"Dc1", NULL};
|
|
static char *Char_Dc2[] = {"Dc2", NULL};
|
|
static char *Char_Dc3[] = {"Dc3", NULL};
|
|
static char *Char_Dc4[] = {"Dc4", NULL};
|
|
static char *Char_Nak[] = {"Nak", NULL};
|
|
static char *Char_Syn[] = {"Syn", NULL};
|
|
static char *Char_Etb[] = {"Etb", NULL};
|
|
static char *Char_Can[] = {"Can", NULL};
|
|
static char *Char_Em[] = {"Em", NULL};
|
|
static char *Char_Sub[] = {"Sub", NULL};
|
|
static char *Char_Esc[] = {"Escape", "Esc", NULL};
|
|
static char *Char_Fs[] = {"Fs", NULL};
|
|
static char *Char_Gs[] = {"Gs", NULL};
|
|
static char *Char_Rs[] = {"Rs", NULL};
|
|
static char *Char_Us[] = {"Us", NULL};
|
|
static char *Char_Sp[] = {"Space", "Sp", NULL};
|
|
static char *Char_Del[] = {"Rubout", "Del", "Delete", NULL};
|
|
|
|
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, char *fmt, ...)
|
|
{
|
|
char string[128], *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;
|
|
}
|
|
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 (quote == '|' || (unreadable && !collon)) {
|
|
/* Set unreadable field, this atom needs quoting to be read back */
|
|
object = ATOM(string);
|
|
object->data.atom->unreadable = 1;
|
|
}
|
|
|
|
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);
|
|
}
|
|
|
|
/* 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)->string);
|
|
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 */
|
|
|
|
int i;
|
|
LispAtom *atom;
|
|
|
|
i = STRHASH(symbol);
|
|
atom = pack->atoms[i];
|
|
while (atom) {
|
|
if (strcmp(atom->string, symbol) == 0) {
|
|
object = atom->object;
|
|
break;
|
|
}
|
|
|
|
atom = atom->next;
|
|
}
|
|
|
|
/* 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 &&
|
|
((*str == '-' && integer == LONG_MIN) ||
|
|
(*str != '-' && integer == LONG_MAX))) {
|
|
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) {
|
|
char **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 = strlen(ATOMID(CAR(fields)));
|
|
/* MAKE- */
|
|
if (len + 6 > sizeof(stk))
|
|
str = LispMalloc(len + 6);
|
|
else
|
|
str = stk;
|
|
sprintf(str, "MAKE-%s", ATOMID(CAR(fields)));
|
|
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);
|
|
}
|