← Back to branch summary

~ubuntu-branches/ubuntu/lucid/x11-apps/lucid

« back to all changes in this revision

Viewing changes to xedit/lisp/read.c

  • Committer: Bazaar Package Importer
  • Author(s): Julien Cristau
  • Date: 2008-09-23 00:24:45 UTC
  • mfrom: (1.1.2 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080923002445-mb2rwkif45zz1vlj
Tags: 7.3+4
http://bugs.debian.org/321434
* Remove xedit from the package, it's unmaintained and broken
  (closes: #321434).
* Remove xedit's conffiles on upgrade.

Show diffs side-by-side

added added

removed removed

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