diff options
Diffstat (limited to 'lisp/read.c')
| -rw-r--r-- | lisp/read.c | 2058 |
1 files changed, 2058 insertions, 0 deletions
diff --git a/lisp/read.c b/lisp/read.c new file mode 100644 index 0000000..b8872a2 --- /dev/null +++ b/lisp/read.c @@ -0,0 +1,2058 @@ +/* + * 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.34 2003/01/13 03:57:58 paulo Exp $ */ + +#include <errno.h> +#include "read.h" +#include "package.h" +#include "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") + +/* + * 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, *recursive_p; + + recursive_p = ARGUMENT(3); + 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 *result; + + LispObj *input_stream, *eof_error_p, *eof_value, *recursive_p; + + recursive_p = ARGUMENT(3); + 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; + + result = 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, *recursive_p; + + recursive_p = ARGUMENT(3); + 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); +} |