2
Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
4
This file is part of GNU Common Lisp, herein referred to as GCL
6
GCL is free software; you can redistribute it and/or modify it under
7
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
8
the Free Software Foundation; either version 2, or (at your option)
11
GCL is distributed in the hope that it will be useful, but WITHOUT
12
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
14
License for more details.
16
You should have received a copy of the GNU Library General Public License
17
along with GCL; see the file COPYING. If not, write to the Free Software
18
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
30
current_readtable(void);
36
parse_number(char *,int,int *,int);
38
#define token_buffer token->st.st_self
39
/* the active length of the token */
44
object dispatch_reader;
47
#define cat(c) (READtable->rt.rt_self[char_code((c))] \
50
#ifndef SHARP_EQ_CONTEXT_SIZE
51
#define SHARP_EQ_CONTEXT_SIZE 500
57
READtable = current_readtable();
60
struct sharp_eq_context_struct {
64
} sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
69
I believe that there is no need to enter
70
sharp_eq_context to mark_origin.
79
READtable = current_readtable();
80
x = symbol_value(sLAread_default_float_formatA);
81
if (x == sLshort_float)
82
READdefault_float_format = 'S';
83
else if (x == sLsingle_float || x == sLdouble_float || x == sLlong_float)
84
READdefault_float_format = 'F';
87
sLAread_default_float_formatA->s.s_dbind = sLsingle_float;
88
FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.",
91
x = symbol_value(sLAread_baseA);
92
if (type_of(x) != t_fixnum || fix(x) < 2 || fix(x) > 36) {
94
sLAread_baseA->s.s_dbind = make_fixnum(10);
95
FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x);
98
READsuppress = symbol_value(sLAread_suppressA) != Cnil;
99
sharp_eq_context_max = 0;
105
setup_standard_READ()
107
READtable = standard_readtable;
108
READdefault_float_format = 'F';
110
READsuppress = FALSE;
111
sharp_eq_context_max = 0;
119
return(code_char(readc_stream(in)));
122
#define read_char(in) code_char(readc_stream(in))
128
if (type_of(c) != t_character)
129
FEwrong_type_argument(sLcharacter, c);
130
unreadc_stream(char_code(c), in);
134
Peek_char corresponds to COMMON Lisp function PEEK-CHAR.
135
When pt is TRUE, preceeding whitespaces are ignored.
147
while (cat(c) == cat_whitespace);
159
read_object_recursive(in)
165
object old_READtable = READtable;
166
int old_READdefault_float_format = READdefault_float_format;
167
int old_READbase = READbase;
168
bool old_READsuppress = READsuppress;
170
/* BUG FIX by Toshiba */
171
vs_push(old_READtable);
173
frs_push(FRS_PROTECT, Cnil);
179
READtable = current_readtable();
180
x = symbol_value(sLAread_default_float_formatA);
181
if (x == sLshort_float)
182
READdefault_float_format = 'S';
183
else if (x == sLsingle_float || x == sLdouble_float || x == sLlong_float)
184
READdefault_float_format = 'F';
187
sLAread_default_float_formatA->s.s_dbind = sLsingle_float;
188
FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.",
191
x = symbol_value(sLAread_baseA);
192
if (type_of(x) != t_fixnum || fix(x) < 2 || fix(x) > 36) {
194
sLAread_baseA->s.s_dbind = make_fixnum(10);
195
FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x);
198
READsuppress = symbol_value(sLAread_suppressA) != Cnil;
206
READtable = old_READtable;
207
READdefault_float_format = old_READdefault_float_format;
208
READbase = old_READbase;
209
READsuppress = old_READsuppress;
211
/* BUG FIX by Toshiba */
216
unwind(nlj_fr, nlj_tag);
224
read_object_non_recursive(in)
230
object old_READtable;
231
int old_READdefault_float_format;
233
int old_READsuppress;
234
int old_sharp_eq_context_max;
235
struct sharp_eq_context_struct
236
old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
239
old_READtable = READtable;
240
old_READdefault_float_format = READdefault_float_format;
241
old_READbase = READbase;
242
old_READsuppress = READsuppress;
243
old_sharp_eq_context_max = sharp_eq_context_max;
244
/* BUG FIX by Toshiba */
245
vs_push(old_READtable);
246
for (i = 0; i < sharp_eq_context_max; i++)
247
old_sharp_eq_context[i] = sharp_eq_context[i];
248
old_backq_level = backq_level;
251
frs_push(FRS_PROTECT, Cnil);
260
if (sharp_eq_context_max > 0)
261
x = vs_head = patch_sharp(x);
268
READtable = old_READtable;
269
READdefault_float_format = old_READdefault_float_format;
270
READbase = old_READbase;
271
READsuppress = old_READsuppress;
272
sharp_eq_context_max = old_sharp_eq_context_max;
273
for (i = 0; i < sharp_eq_context_max; i++)
274
sharp_eq_context[i] = old_sharp_eq_context[i];
275
backq_level = old_backq_level;
278
unwind(nlj_fr, nlj_tag);
281
/* BUG FIX by Toshiba */
287
standard_read_object_non_recursive(in)
293
object old_READtable;
294
int old_READdefault_float_format;
296
int old_READsuppress;
297
int old_sharp_eq_context_max;
298
struct sharp_eq_context_struct
299
old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
302
old_READtable = READtable;
303
old_READdefault_float_format = READdefault_float_format;
304
old_READbase = READbase;
305
old_READsuppress = READsuppress;
306
old_sharp_eq_context_max = sharp_eq_context_max;
308
vs_push(old_READtable);
309
for (i = 0; i < sharp_eq_context_max; i++)
310
old_sharp_eq_context[i] = sharp_eq_context[i];
311
old_backq_level = backq_level;
313
setup_standard_READ();
315
frs_push(FRS_PROTECT, Cnil);
324
if (sharp_eq_context_max > 0)
325
x = vs_head = patch_sharp(x);
332
READtable = old_READtable;
333
READdefault_float_format = old_READdefault_float_format;
334
READbase = old_READbase;
335
READsuppress = old_READsuppress;
336
sharp_eq_context_max = old_sharp_eq_context_max;
337
for (i = 0; i < sharp_eq_context_max; i++)
338
sharp_eq_context[i] = old_sharp_eq_context[i];
339
backq_level = old_backq_level;
342
unwind(nlj_fr, nlj_tag);
349
#ifdef UNIX /* faster code for inner loop from file stream */
350
#define xxxread_char_to(res,in,eof_code) \
352
if(fp=in->sm.sm_fp) \
353
{int ch = getc(fp); \
355
if (feof(fp)) { eof_code;} \
356
else if (in->sm.sm_mode==smm_socket) \
357
{ ch = getOneChar(fp); \
358
if (ch==EOF) { eof_code;}}} \
359
else res=code_char(ch);} \
361
{ if (stream_at_end(in)) \
363
else res=read_char(in);}} while(0)
365
#define read_char_to(res,in,eof_code) \
367
if((fp=in->sm.sm_fp)) \
368
{int ch = getc(fp); \
369
if (ch==EOF && feof(fp)) \
371
else res=code_char(ch);} \
374
if(stream_at_end(in)) {eof_code ;} \
375
ch = readc_stream(in); \
376
if (ch == EOF) { eof_code;} \
377
res = code_char(ch); \
380
#define read_char_to(res,in,eof_code) \
381
do {if(stream_at_end(in)) {eof_code ;} \
382
else { int ch = readc_stream(in); \
383
if (ch == EOF) { eof_code;} \
384
res = code_char(ch); \
390
too_long_token(void);
392
Read_object(in) reads an object from stream in.
393
This routine corresponds to COMMON Lisp function READ.
396
/* FIXME What should this be? Apparently no reliable way to use value stack */
397
#define MAX_PACKAGE_STACK 1024
398
static object P0[MAX_PACKAGE_STACK],*PP0=P0,LP;
410
int colon=0, colon_type;
418
vs_check_push(delimiting_char);
419
delimiting_char = OBJNULL;
420
df = detect_eos_flag;
421
detect_eos_flag = FALSE;
423
in_list_flag = FALSE;
427
do { read_char_to(c,in, {
435
} while (a == cat_whitespace);
436
if (c->ch.ch_code == '(') { /* Loose package extension */
437
LP=LP || PP0==P0 ? LP : PP0[-1]; /* push loose packages into nested lists */
439
if (PP0-P0>=MAX_PACKAGE_STACK)
440
FEerror("Too many nested package specifiers",0);
445
FEerror("Loose package prefix must be followed by a list",0);
446
if (c->ch.ch_code==')' && PP0>P0) PP0--; /* regardless of error behavior,
447
will pop stack to beginning as parens
448
must match before the reader starts */
449
delimiting_char = vs_head;
450
if (delimiting_char != OBJNULL && c == delimiting_char) {
451
delimiting_char = OBJNULL;
455
delimiting_char = OBJNULL;
456
if (a == cat_terminating || a == cat_non_terminating)
458
object *fun_box = vs_top;
460
old_vs_base = vs_base;
467
READtable->rt.rt_self[char_code(c)].rte_macro;
471
i = vs_top - vs_base;
473
vs_base = old_vs_base;
474
vs_top = old_vs_top + 1;
478
vs_push(make_fixnum(i));
479
FEerror("The readmacro ~S returned ~D values.",
480
2, fun_box[0], vs_top[-1]);
483
vs_base = old_vs_base;
488
length = 0; tok_leng=0;
492
if (length >= token->st.st_dim)
494
token_buffer[(tok_leng++,length++)] = char_code(c);
496
read_char_to(c,in,goto M);
499
if (a == cat_single_escape) {
503
} else if (a == cat_multiple_escape) {
506
if (stream_at_end(in))
510
if (a == cat_single_escape) {
513
} else if (a == cat_multiple_escape)
515
if (length >= token->st.st_dim)
517
token_buffer[(tok_leng++,length++)] = char_code(c);
520
} else if (a == cat_terminating) {
522
} else if (a == cat_whitespace) {
523
/* skip all whitespace after trailing colon if no escape seen */
524
if (colon+colon_type==length && !escape_flag)
529
else if ('a' <= char_code(c) && char_code(c) <= 'z')
530
c = code_char(char_code(c) - ('a' - 'A'));
531
else if (char_code(c) == ':') {
532
if (colon_type == 0) {
535
} else if (colon_type == 1 && colon == length-1)
539
/* Colon has appeared twice. */
542
if (preserving_whitespace_flag || cat(c) != cat_whitespace)
547
token->st.st_fillp = length;
551
if (ilf && !escape_flag &&
552
length == 1 && token->st.st_self[0] == '.') {
556
} else if (!escape_flag && length > 0) {
557
for (i = 0; i < length; i++)
558
if (token->st.st_self[i] != '.')
560
FEerror("Dots appeared illegally.", 0);
564
token->st.st_fillp = length;
565
if (escape_flag || (READbase<=10 && token_buffer[0]>'9'))
567
x = parse_number(token_buffer, length, &i, READbase);
568
if (x != OBJNULL && length == i) {
574
if (colon_type == 1 /* && length > colon + 1 */) {
578
token->st.st_fillp = colon;
579
p = find_package(token);
581
vs_push(copy_simple_string(token));
582
FEerror("There is no package with the name ~A.",
586
for (i = colon + 1; i < length; i++)
587
token_buffer[i - (colon + 1)]
589
token->st.st_fillp = length - (colon + 1);
591
x = find_symbol(token, p);
592
if (intern_flag != EXTERNAL) {
593
vs_push(copy_simple_string(token));
594
FEerror("Cannot find the external symbol ~A in ~S.",
596
/* no need to push a package */
601
} else if (colon_type == 2 /* && colon > 0 && length > colon + 2 */) {
602
token->st.st_fillp = colon;
603
p = find_package(token);
605
vs_push(copy_simple_string(token));
606
FEerror("There is no package with the name ~A.",
609
for (i = colon + 2; i < length; i++)
610
token_buffer[i - (colon + 2)]
612
token->st.st_fillp = length - (colon + 2);
614
p = current_package();
615
/* loose package is an empty token following a non-beginning
616
colon with no escape, to allow for ||*/
617
if (!token->st.st_fillp && colon && !escape_flag) {
621
/* unless package specified for this symbol, use loose package if present */
622
if (PP0>P0 && !colon_type)
625
x = intern(token, p);
627
if (x->s.s_self == token_buffer) {
629
x->s.s_self = alloc_relblock(token->st.st_fillp);
630
for (i = 0; i < token->st.st_fillp; i++)
631
x->s.s_self[i] = token_buffer[i];
639
Lleft_parenthesis_reader()
649
delimiting_char = code_char(')');
656
FEerror("A dot appeared after a left parenthesis.", 0);
658
*p = read_object(in);
660
FEerror("Two dots appeared consecutively.", 0);
662
while (cat(c) == cat_whitespace)
664
if (char_code(c) != ')')
665
FEerror("A dot appeared before a right parenthesis.", 0);
666
else if (PP0>P0) PP0--; /* should be the only other place
667
outside of read_object where
668
closing parens are read */
672
*p = make_cons(x, Cnil);
674
p = &((*p)->c.c_cdr);
682
#define is_exponent_marker(i) \
683
((i) == 'e' || (i) == 'E' || \
684
(i) == 's' || (i) == 'S' || (i) == 'f' || (i) == 'F' || \
685
(i) == 'd' || (i) == 'D' || (i) == 'l' || (i) == 'L' || \
686
(i) == 'b' || (i) == 'B')
690
Parse_number(s, end, ep, radix) parses C string s
691
up to (but not including) s[end]
692
using radix as the radix for the rational number.
693
(For floating numbers, radix should be 10.)
694
When parsing has been succeeded,
695
the index of the next character is assigned to *ep,
696
and the number is returned as a lisp data object.
697
If not, OBJNULL is returned.
700
parse_number(s, end, ep, radix)
707
double fraction, fraction_unit, f;
708
char exponent_marker;
720
exponent_marker = 'E';
725
else if (s[i] == '-') {
729
integer_part = (object) big_register_0;
730
zero_big(big_register_0);
731
vs_push((object)integer_part);
742
if ((d = digitp(s[i], radix)) < 0)
744
#define MOST_POSITIVE_FIX (((unsigned int) (~0) ) /2)
745
#define TEN_EXPT_9 1000000000
747
if (radix == 10 && TEN_EXPT_9 <MOST_POSITIVE_FIX ) {
753
mul_int_big(1000000000, integer_part);
754
add_int_big(sum, integer_part);
758
} while (i < end && (d = digitp(s[i], radix)) >= 0);
761
while(--chunk> 0) {fac *=10;}
762
mul_int_big(fac,integer_part);
763
add_int_big(sum,integer_part);
770
mul_int_big(radix, integer_part);
771
add_int_big(d, integer_part);
773
} while (i < end && (d = digitp(s[i], radix)) >= 0);
786
else if (digitp(s[i], radix) >= 0)
788
else if (is_exponent_marker(s[i])) {
790
= (double)sign * big_to_double(integer_part);
799
if (is_exponent_marker(s[i])) {
800
fraction = (double)sign * big_to_double(integer_part);
808
if (sign < 0 && signe(MP(integer_part)))
809
set_big_sign(integer_part,-1);
810
x = normalize_big_to_object(integer_part);
812
if (x == big_register_0)
813
big_register_0 = alloc_object(t_bignum);
814
zero_big(big_register_0);
825
if ((d = digitp(s[i], radix)) < 0)
828
fraction_unit = 1000000000.0;
836
d = digitp(s[i], radix);
839
} while (k < 9 && d >= 0);
842
fraction += ((double)j /fraction_unit);
843
if (i >= end || d < 0)
845
fraction_unit *= 1000000000.0;
847
fraction += big_to_double(integer_part);
848
fraction *= (double)sign;
851
if (is_exponent_marker(s[i]))
861
exponent_marker = s[i];
868
else if (s[i] == '-') {
874
if ((d = digitp(s[i], radix)) < 0)
878
exponent = 10 * exponent + d;
880
} while (i < end && (d = digitp(s[i], radix)) >= 0);
883
/* Use pow because it is more accurate */
884
{ double po = pow(10.0,(double)(sign * d));
886
{ fraction = fraction *pow(10.0,(double)(sign * (d-1)));
889
fraction = fraction * po;}
893
/* if ((*((int *)&fraction +HIND) & 0x7ff00000) == 0x7ff00000)*/
894
if (!ISFINITE(fraction))
895
FEerror("Floating-point overflow.", 0);
897
switch (exponent_marker) {
900
exponent_marker = READdefault_float_format;
904
x = make_shortfloat((shortfloat)fraction);
907
case 'f': case 'F': case 'd': case 'D': case 'l': case 'L':
908
x = make_longfloat((longfloat)fraction);
915
zero_big(big_register_0);
923
set_big_sign(integer_part,-1);
924
vs_push(normalize_big_to_object(integer_part));
926
if (vs_head == big_register_0)
927
big_register_0 = new_bignum();
928
zero_big(big_register_0);
931
if ((d = digitp(s[i], radix)) < 0)
933
integer_part = big_register_0;
934
/* zero_big(integer_part); */
936
mul_int_big(radix, integer_part);
937
add_int_big(d, integer_part);
939
} while (i < end && (d = digitp(s[i], radix)) >= 0);
940
vs_push(normalize_big_to_object(integer_part));
941
x = make_ratio(vs_top[-2], vs_top[-1]);
953
zero_big(big_register_0);
961
parse_integer(s, end, ep, radix)
975
else if (s[i] == '-') {
979
integer_part = big_register_0;
980
vs_push((object)integer_part);
983
if ((d = digitp(s[i], radix)) < 0)
987
mul_int_big(radix, integer_part);
988
add_int_big(d, integer_part);
990
} while (i < end && (d = digitp(s[i], radix)) >= 0);
994
set_big_sign(integer_part,-1);
995
x = normalize_big_to_object(integer_part);
997
if (x == big_register_0)
998
big_register_0 = alloc_object(t_bignum);
999
zero_big(big_register_0);
1010
zero_big(big_register_0);
1017
too_long_string(void);
1020
Read_string(delim, in) reads
1021
a simple string terminated by character code delim
1022
and places it in token.
1023
Delim is not included in the string but discarded.
1026
read_string(delim, in)
1036
if (char_code(c) == delim)
1038
else if (cat(c) == cat_single_escape)
1040
if (i >= token->st.st_dim)
1042
token_buffer[i++] = char_code(c);
1044
token->st.st_fillp = i;
1048
Read_constituent(in) reads
1049
a sequence of constituent characters from stream in
1050
and places it in token_buffer.
1053
read_constituent(in)
1061
read_char_to(c,in,goto FIN);
1062
if (cat(c) != cat_constituent) {
1067
token_buffer[i++] = j;
1070
token->st.st_fillp = i;
1075
Ldouble_quote_reader()
1079
read_string('"', vs_base[0]);
1080
vs_base[0] = copy_simple_string(token);
1095
if (READtable->rt.rt_self[char_code(c)].rte_dtab == NULL)
1096
FEerror("~C is not a dispatching macro character", 1, c);
1099
d = digitp(char_code(c), 10);
1105
d = digitp(char_code(c), 10);
1107
vs_push(make_fixnum(i));
1112
READtable->rt.rt_self[char_code(vs_base[1])].rte_dtab[char_code(c)];
1118
Lsingle_quote_reader()
1123
vs_push(read_object(vs_base[0]));
1127
vs_base[0] = vs_pop;
1131
Lright_parenthesis_reader()
1147
object str= vs_base[0];
1151
{ read_char_to(c,str, goto L); }
1152
while (char_code(c) != '\n');
1160
Lbackquote_reader(){}
1167
extra_argument(int);
1175
if (vs_base[2] != Cnil && !READsuppress)
1176
extra_argument('C');
1179
c = read_char(vs_base[0]);
1180
if (char_code(c) != '(')
1181
FEerror("A left parenthesis is expected.", 0);
1182
delimiting_char = code_char(')');
1183
x = read_object(vs_base[0]);
1185
FEerror("No real part.", 0);
1187
delimiting_char = code_char(')');
1188
x = read_object(vs_base[0]);
1190
FEerror("No imaginary part.", 0);
1192
delimiting_char = code_char(')');
1193
x = read_object(vs_base[0]);
1195
FEerror("A right parenthesis is expected.", 0);
1196
if (READsuppress) vs_base[0]= Cnil ;
1198
if (contains_sharp_comma(vs_base[1]) ||
1199
contains_sharp_comma(vs_base[2])) {
1200
vs_base[0] = alloc_object(t_complex);
1201
vs_base[0]->cmp.cmp_real = vs_base[1];
1202
vs_base[0]->cmp.cmp_imag = vs_base[2];
1204
check_type_number(&vs_base[1]);
1205
check_type_number(&vs_base[2]);
1206
vs_base[0] = make_complex(vs_base[1], vs_base[2]);
1208
vs_top = vs_base + 1;
1212
Lsharp_backslash_reader()
1217
if (vs_base[2] != Cnil && !READsuppress)
1218
if (type_of(vs_base[2]) != t_fixnum ||
1219
fix(vs_base[2]) != 0)
1220
FEerror("~S is an illegal CHAR-FONT.", 1, vs_base[2]);
1221
/* assuming that CHAR-FONT-LIMIT is 1 */
1224
unread_char(code_char('\\'), vs_base[0]);
1226
(void)read_object(vs_base[0]);
1230
READsuppress = TRUE;
1231
(void)read_object(vs_base[0]);
1232
READsuppress = FALSE;
1234
if (c->s.s_fillp == 1) {
1235
vs_base[0] = code_char(c->ust.ust_self[0]);
1238
if (string_equal(c, STreturn))
1239
vs_base[0] = code_char('\r');
1240
else if (string_equal(c, STspace))
1241
vs_base[0] = code_char(' ');
1242
else if (string_equal(c, STrubout))
1243
vs_base[0] = code_char('\177');
1244
else if (string_equal(c, STpage))
1245
vs_base[0] = code_char('\f');
1246
else if (string_equal(c, STtab))
1247
vs_base[0] = code_char('\t');
1248
else if (string_equal(c, STbackspace))
1249
vs_base[0] = code_char('\b');
1250
else if (string_equal(c, STlinefeed) || string_equal(c, STnewline))
1251
vs_base[0] = code_char('\n');
1252
else if (c->s.s_fillp == 2 && c->s.s_self[0] == '^')
1253
vs_base[0] = code_char(c->s.s_self[1] & 037);
1254
else if (c->s.s_self[0] =='\\' && c->s.s_fillp > 1) {
1256
for (n = 0, i = 1; i < c->s.s_fillp; i++)
1257
if (c->s.s_self[i] < '0' || '7' < c->s.s_self[i])
1258
FEerror("Octal digit expected.", 0);
1260
n = 8*n + c->s.s_self[i] - '0';
1261
vs_base[0] = code_char(n & 0377);
1263
FEerror("~S is an illegal character name.", 1, c);
1267
Lsharp_single_quote_reader()
1271
if(vs_base[2] != Cnil && !READsuppress)
1272
extra_argument('#');
1275
vs_push(sLfunction);
1276
vs_push(read_object(vs_base[0]));
1280
vs_base[0] = vs_pop;
1293
Lsharp_left_parenthesis_reader()
1303
if (vs_base[2] == Cnil || READsuppress)
1305
else if (type_of(vs_base[2]) == t_fixnum)
1306
dim = fix(vs_base[2]);
1310
if (backq_level > 0) {
1311
unreadc_stream('(', in);
1312
vs_push(read_object(in));
1313
a = backq_car(vs_base[1]);
1314
if (a == APPEND || a == NCONC)
1315
FEerror(",at or ,. has appeared in an illegal position.", 0);
1319
for (x = vs_base[2]; !endp(x); x = x->c.c_cdr) {
1320
vs_check_push(x->c.c_car);
1332
vs_push(vs_base[2]);
1338
vs_base = vs_top - 1;
1344
delimiting_char = code_char(')');
1345
x = read_object(in);
1354
FEerror("Too many elements in #(...).", 0);
1357
FEerror("Cannot fill the vector #().", 0);
1359
for (; dimcount < dim; dimcount++)
1363
{BEGIN_NO_INTERRUPT;
1364
x = alloc_simple_vector(dimcount, aet_object);
1367
= (object *)alloc_relblock(dimcount * sizeof(object));
1369
for (dim = 0; dim < dimcount; dim++)
1370
x->v.v_self[dim] = vsp[dim];
1377
Lsharp_asterisk_reader()
1386
read_constituent(vs_base[0]);
1392
if (vs_head == Cnil)
1394
else if (type_of(vs_head) == t_fixnum)
1402
if (stream_at_end(in))
1405
if (char_code(x) != '0' && char_code(x) != '1') {
1414
FEerror("Too many elements in #*....", 0);
1417
error("Cannot fill the bit-vector #*.");
1419
for (; dimcount < dim; dimcount++)
1423
{BEGIN_NO_INTERRUPT;
1424
x = alloc_simple_bitvector(dimcount);
1426
x->bv.bv_self = alloc_relblock((dimcount + 7)/8);
1428
for (dim = 0; dim < dimcount; dim++)
1429
if (char_code(vsp[dim]) == '0')
1430
x->bv.bv_self[dim/8] &= ~(0200 >> dim%8);
1432
x->bv.bv_self[dim/8] |= 0200 >> dim%8;
1439
Lsharp_colon_reader()
1446
if (vs_base[2] != Cnil && !READsuppress)
1447
extra_argument(':');
1453
escape_flag = FALSE;
1454
length = 0; tok_leng=0;
1457
if (length >= token->st.st_dim)
1459
token_buffer[(tok_leng++,length++)] = char_code(c);
1461
if (stream_at_end(in))
1466
if (a == cat_single_escape) {
1468
a = cat_constituent;
1470
} else if (a == cat_multiple_escape) {
1473
if (stream_at_end(in))
1477
if (a == cat_single_escape) {
1479
a = cat_constituent;
1480
} else if (a == cat_multiple_escape)
1482
if (length >= token->st.st_dim)
1484
token_buffer[(tok_leng++,length++)] = char_code(c);
1487
} else if ('a' <= char_code(c) && char_code(c) <= 'z')
1488
c = code_char(char_code(c) - ('a' - 'A'));
1489
if (a == cat_whitespace || a == cat_terminating)
1492
if (preserving_whitespace_flag || cat(c) != cat_whitespace)
1500
token->st.st_fillp = length;
1501
vs_base[0] = copy_simple_string(token);
1502
vs_base[0] = make_symbol(vs_base[0]);
1509
if(vs_base[2] != Cnil && !READsuppress)
1510
extra_argument('.');
1514
read_object(vs_base[0]);
1518
vs_base[0] = read_object(vs_base[0]);
1519
vs_base[0] = ieval(vs_base[0]);
1523
Lsharp_comma_reader()
1526
if(vs_base[2] != Cnil && !READsuppress)
1527
extra_argument(',');
1531
read_object(vs_base[0]);
1535
vs_base[0] = read_object(vs_base[0]);
1536
vs_base[0] = ieval(vs_base[0]);
1540
FFN(siLsharp_comma_reader_for_compiler)()
1543
if(vs_base[2] != Cnil && !READsuppress)
1544
extra_argument(',');
1551
vs_base[0] = read_object(vs_base[0]);
1552
vs_base[0] = make_cons(siSsharp_comma, vs_base[0]);
1559
Lsharp_exclamation_reader()
1562
if(vs_base[2] != Cnil && !READsuppress)
1563
extra_argument('!');
1570
vs_base[0] = read_object(vs_base[0]);
1571
if (sharp_eq_context_max > 0)
1572
vs_base[0]=patch_sharp(vs_base[0]);
1582
if(vs_base[2] != Cnil && !READsuppress)
1583
extra_argument('B');
1586
read_constituent(vs_base[0]);
1592
= parse_number(token_buffer, token->st.st_fillp, &i, 2);
1593
if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
1594
FEerror("Cannot parse the #B readmacro.", 0);
1595
if (type_of(vs_base[0]) == t_shortfloat ||
1596
type_of(vs_base[0]) == t_longfloat)
1597
FEerror("The float ~S appeared after the #B readmacro.",
1606
if(vs_base[2] != Cnil && !READsuppress)
1607
extra_argument('O');
1610
read_constituent(vs_base[0]);
1616
= parse_number(token_buffer, token->st.st_fillp, &i, 8);
1617
if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
1618
FEerror("Cannot parse the #O readmacro.", 0);
1619
if (type_of(vs_base[0]) == t_shortfloat ||
1620
type_of(vs_base[0]) == t_longfloat)
1621
FEerror("The float ~S appeared after the #O readmacro.",
1630
if(vs_base[2] != Cnil && !READsuppress)
1631
extra_argument('X');
1634
read_constituent(vs_base[0]);
1640
= parse_number(token_buffer, token->st.st_fillp, &i, 16);
1641
if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
1642
FEerror("Cannot parse the #X readmacro.", 0);
1643
if (type_of(vs_base[0]) == t_shortfloat ||
1644
type_of(vs_base[0]) == t_longfloat)
1645
FEerror("The float ~S appeared after the #X readmacro.",
1657
else if (type_of(vs_base[2]) == t_fixnum) {
1658
radix = fix(vs_base[2]);
1659
if (radix > 36 || radix < 2)
1660
FEerror("~S is an illegal radix.", 1, vs_base[2]);
1662
FEerror("No radix was supplied in the #R readmacro.", 0);
1665
read_constituent(vs_base[0]);
1671
= parse_number(token_buffer, token->st.st_fillp, &i, radix);
1672
if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
1673
FEerror("Cannot parse the #R readmacro.", 0);
1674
if (type_of(vs_base[0]) == t_shortfloat ||
1675
type_of(vs_base[0]) == t_longfloat)
1676
FEerror("The float ~S appeared after the #R readmacro.",
1680
/*static void Lsharp_A_reader(){}*/
1682
/*static void Lsharp_S_reader(){}*/
1694
if (vs_base[2] == Cnil)
1695
FEerror("The #= readmacro requires an argument.", 0);
1696
for (i = 0; i < sharp_eq_context_max; i++)
1697
if (eql(sharp_eq_context[i].sharp_index, vs_base[2]))
1698
FEerror("Duplicate definitions for #~D=.",
1700
if (sharp_eq_context_max >= SHARP_EQ_CONTEXT_SIZE)
1701
FEerror("Too many #= definitions.", 0);
1702
i = sharp_eq_context_max++;
1703
sharp_eq_context[i].sharp_index = vs_base[2];
1704
sharp_eq_context[i].sharp_sharp = OBJNULL;
1706
= sharp_eq_context[i].sharp_eq
1707
= read_object(vs_base[0]);
1708
if (sharp_eq_context[i].sharp_eq
1709
== sharp_eq_context[i].sharp_sharp)
1710
FEerror("#~D# is defined by itself.",
1711
1, sharp_eq_context[i].sharp_index);
1716
Lsharp_sharp_reader()
1726
if (vs_base[2] == Cnil)
1727
FEerror("The ## readmacro requires an argument.", 0);
1729
if (i >= sharp_eq_context_max)
1730
FEerror("#~D# is undefined.", 1, vs_base[2]);
1731
else if (eql(sharp_eq_context[i].sharp_index,
1734
if (sharp_eq_context[i].sharp_sharp == OBJNULL) {
1735
sharp_eq_context[i].sharp_sharp
1736
= alloc_object(t_spice);
1738
vs_base[0] = sharp_eq_context[i].sharp_sharp;
1747
x->c.c_car = patch_sharp(x->c.c_car);
1748
if (type_of(x->c.c_cdr) == t_cons)
1751
x->c.c_cdr = patch_sharp(x->c.c_cdr);
1763
switch (type_of(x)) {
1768
for (i = 0; i < sharp_eq_context_max; i++)
1769
if (sharp_eq_context[i].sharp_sharp == x)
1770
return(sharp_eq_context[i].sharp_eq);
1775
x->c.c_car = patch_sharp(x->c.c_car);
1776
x->c.c_cdr = patch_sharp(x->c.c_cdr);
1778
patch_sharp_cons(x);
1785
if ((enum aelttype)x->v.v_elttype != aet_object)
1788
for (i = 0; i < x->v.v_fillp; i++)
1789
x->v.v_self[i] = patch_sharp(x->v.v_self[i]);
1796
if ((enum aelttype)x->a.a_elttype != aet_object)
1799
for (i = 0, j = 1; i < x->a.a_rank; i++)
1800
j *= x->a.a_dims[i];
1801
for (i = 0; i < j; i++)
1802
x->a.a_self[i] = patch_sharp(x->a.a_self[i]);
1806
{object def = x->str.str_def;
1808
i=S_DATA(def)->length;
1810
structure_set(x,def,i,patch_sharp(structure_ref(x,def,i)));
1820
static void Lsharp_plus_reader(){}
1822
static void Lsharp_minus_reader(){}
1824
/*static void Lsharp_less_than_reader(){}*/
1826
/*static void Lsharp_whitespace_reader(){}*/
1828
/*static void Lsharp_right_parenthesis_reader(){}*/
1831
Lsharp_vertical_bar_reader()
1837
if (vs_base[2] != Cnil && !READsuppress)
1838
extra_argument('|');
1842
c = readc_stream(vs_base[0]);
1845
c = readc_stream(vs_base[0]);
1848
} else if (c == '|') {
1849
c = readc_stream(vs_base[0]);
1865
Ldefault_dispatch_macro()
1867
FEerror("The default dispatch macro signalled an error.", 0);
1871
#p" ... " returns the pathname with namestring ... .
1877
if (vs_base[2] != Cnil && !READsuppress)
1878
extra_argument('p');
1881
vs_base[0] = read_object(vs_base[0]);
1882
vs_base[0] = coerce_to_pathname(vs_base[0]);
1886
#" ... " returns the pathname with namestring ... .
1889
Lsharp_double_quote_reader()
1893
if (vs_base[2] != Cnil && !READsuppress)
1894
extra_argument('"');
1896
unread_char(vs_base[1], vs_base[0]);
1898
vs_base[0] = read_object(vs_base[0]);
1899
vs_base[0] = coerce_to_pathname(vs_base[0]);
1903
#$ fixnum returns a random-state with the fixnum
1907
Lsharp_dollar_reader()
1912
if (vs_base[2] != Cnil && !READsuppress)
1913
extra_argument('$');
1916
vs_base[0] = read_object(vs_base[0]);
1917
if (type_of(vs_base[0]) != t_fixnum)
1918
FEerror("Cannot make a random-state with the value ~S.",
1920
i = fix(vs_base[0]);
1921
vs_base[0] = alloc_object(t_random);
1922
vs_base[0]->rnd.rnd_value = i;
1930
copy_readtable(from, to)
1936
{BEGIN_NO_INTERRUPT;
1938
to = alloc_object(t_readtable);
1939
to->rt.rt_self = NULL;
1940
/* For GBC not to go mad. */
1942
/* Saving for GBC. */
1946
alloc_contblock(RTABSIZE * sizeof(struct rtent));
1947
for (i = 0; i < RTABSIZE; i++)
1948
rtab[i] = from->rt.rt_self[i];
1949
/* structure assignment */
1951
rtab=to->rt.rt_self;
1952
for (i = 0; i < RTABSIZE; i++)
1953
if (from->rt.rt_self[i].rte_dtab != NULL) {
1956
alloc_contblock(RTABSIZE * sizeof(object));
1957
for (j = 0; j < RTABSIZE; j++)
1959
= from->rt.rt_self[i].rte_dtab[j];
1971
r = symbol_value(Vreadtable);
1972
if (type_of(r) != t_readtable) {
1973
Vreadtable->s.s_dbind = copy_readtable(standard_readtable,sLnil);
1974
FEerror("The value of *READTABLE*, ~S, was not a readtable.",
1981
@(defun read (&optional (strm `symbol_value(sLAstandard_inputA)`)
1988
strm = symbol_value(sLAstandard_inputA);
1989
else if (strm == Ct)
1990
strm = symbol_value(sLAterminal_ioA);
1991
check_type_stream(&strm);
1992
if (recursivep == Cnil)
1993
preserving_whitespace_flag = FALSE;
1994
detect_eos_flag = TRUE;
1995
if (recursivep == Cnil)
1996
x = read_object_non_recursive(strm);
1998
x = read_object_recursive(strm);
2000
if (eof_errorp == Cnil && recursivep == Cnil)
2002
end_of_stream(strm);
2007
@(static defun read_preserving_whitespace
2008
(&optional (strm `symbol_value(sLAstandard_inputA)`)
2016
strm = symbol_value(sLAstandard_inputA);
2017
else if (strm == Ct)
2018
strm = symbol_value(sLAterminal_ioA);
2019
check_type_stream(&strm);
2020
while (!stream_at_end(strm)) {
2021
c = read_char(strm);
2022
if (cat(c) != cat_whitespace) {
2023
unread_char(c, strm);
2027
if (eof_errorp == Cnil && recursivep == Cnil)
2029
end_of_stream(strm);
2032
if (recursivep == Cnil)
2033
preserving_whitespace_flag = TRUE;
2034
if (recursivep == Cnil)
2035
x = read_object_non_recursive(strm);
2037
x = read_object_recursive(strm);
2041
@(defun read_delimited_list
2043
&optional (strm `symbol_value(sLAstandard_inputA)`)
2051
volatile int old_sharp_eq_context_max=0;
2052
struct sharp_eq_context_struct
2053
old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
2054
volatile int old_backq_level=0;
2058
check_type_character(&d);
2060
strm = symbol_value(sLAstandard_inputA);
2061
else if (strm == Ct)
2062
strm = symbol_value(sLAterminal_ioA);
2063
check_type_stream(&strm);
2064
if (recursivep == Cnil) {
2065
old_sharp_eq_context_max = sharp_eq_context_max;
2066
for (i = 0; i < sharp_eq_context_max; i++)
2067
old_sharp_eq_context[i] = sharp_eq_context[i];
2068
old_backq_level = backq_level;
2070
frs_push(FRS_PROTECT, Cnil);
2078
preserving_whitespace_flag = FALSE; /* necessary? */
2080
delimiting_char = d;
2081
x = read_object_recursive(strm);
2084
*p = make_cons(x, Cnil);
2085
p = &((*p)->c.c_cdr);
2087
if (recursivep == Cnil) {
2088
if (sharp_eq_context_max > 0)
2093
sharp_eq_context_max = old_sharp_eq_context_max;
2094
for (i = 0; i < sharp_eq_context_max; i++)
2095
sharp_eq_context[i] = old_sharp_eq_context[i];
2096
backq_level = old_backq_level;
2099
unwind(nlj_fr, nlj_tag);
2105
@(defun read_line (&optional (strm `symbol_value(sLAstandard_inputA)`)
2113
strm = symbol_value(sLAstandard_inputA);
2114
else if (strm == Ct)
2115
strm = symbol_value(sLAterminal_ioA);
2116
check_type_stream(&strm);
2117
if (stream_at_end(strm)) {
2118
if (eof_errorp == Cnil && recursivep == Cnil)
2121
end_of_stream(strm);
2125
read_char_to(c,strm,c = Ct; goto FINISH);
2126
if (char_code(c) == '\n') {
2130
if (i >= token->st.st_dim)
2132
token->st.st_self[i++] = char_code(c);
2136
if (i > 0 && token->st.st_self[i-1] == '\r') i--;
2138
token->st.st_fillp = i;
2139
/* no disadvantage to returning an adjustable string */
2141
{object uu= copy_simple_string(token);
2142
/* uu->st.st_hasfillp=TRUE;
2143
uu->st.st_adjustable=TRUE;
2149
@(defun read_char (&optional (strm `symbol_value(sLAstandard_inputA)`)
2155
strm = symbol_value(sLAstandard_inputA);
2156
else if (strm == Ct)
2157
strm = symbol_value(sLAterminal_ioA);
2158
check_type_stream(&strm);
2160
read_char_to(x,strm,goto AT_EOF);
2163
if (eof_errorp == Cnil && recursivep == Cnil)
2166
end_of_stream(strm);
2170
@(defun unread_char (c &optional (strm `symbol_value(sLAstandard_inputA)`))
2172
check_type_character(&c);
2174
strm = symbol_value(sLAstandard_inputA);
2175
else if (strm == Ct)
2176
strm = symbol_value(sLAterminal_ioA);
2177
check_type_stream(&strm);
2178
unread_char(c, strm);
2182
@(defun peek_char (&optional peek_type
2183
(strm `symbol_value(sLAstandard_inputA)`)
2190
strm = symbol_value(sLAstandard_inputA);
2191
else if (strm == Ct)
2192
strm = symbol_value(sLAterminal_ioA);
2193
check_type_stream(&strm);
2195
if (peek_type == Cnil) {
2196
if (stream_at_end(strm)) {
2197
if (eof_errorp == Cnil && recursivep == Cnil)
2200
end_of_stream(strm);
2202
c = read_char(strm);
2203
unread_char(c, strm);
2206
if (peek_type == Ct) {
2207
while (!stream_at_end(strm)) {
2208
c = read_char(strm);
2209
if (cat(c) != cat_whitespace) {
2210
unread_char(c, strm);
2214
if (eof_errorp == Cnil)
2217
end_of_stream(strm);
2219
check_type_character(&peek_type);
2220
while (!stream_at_end(strm)) {
2221
c = read_char(strm);
2222
if (char_eq(c, peek_type)) {
2223
unread_char(c, strm);
2227
if (eof_errorp == Cnil)
2230
end_of_stream(strm);
2233
@(defun listen (&optional (strm `symbol_value(sLAstandard_inputA)`))
2236
strm = symbol_value(sLAstandard_inputA);
2237
else if (strm == Ct)
2238
strm = symbol_value(sLAterminal_ioA);
2239
check_type_stream(&strm);
2240
if (listen_stream(strm))
2246
@(defun read_char_no_hang (&optional (strm `symbol_value(sLAstandard_inputA)`)
2252
strm = symbol_value(sLAstandard_inputA);
2253
else if (strm == Ct)
2254
strm = symbol_value(sLAterminal_ioA);
2255
check_type_stream(&strm);
2256
if (!listen_stream(strm))
2259
@(return `read_char(strm)`)
2262
@(defun clear_input (&optional (strm `symbol_value(sLAstandard_inputA)`))
2265
strm = symbol_value(sLAstandard_inputA);
2266
else if (strm == Ct)
2267
strm = symbol_value(sLAterminal_ioA);
2268
check_type_stream(&strm);
2269
#ifdef LISTEN_FOR_INPUT
2270
while(listen_stream(strm)) {readc_stream(strm);}
2275
@(defun parse_integer (strng
2278
(radix `make_fixnum(10)`)
2283
if (junk_allowed==Cnil)
2284
check_type_string(&strng);
2285
get_string_start_end(strng, start, end, &s, &e);
2286
if (type_of(radix) != t_fixnum ||
2287
fix(radix) < 2 || fix(radix) > 36)
2288
FEerror("~S is an illegal radix.", 1, radix);
2290
while (READtable->rt.rt_self[(unsigned char)strng->st.st_self[s]].rte_chattrib
2291
== cat_whitespace && s < e)
2294
if (junk_allowed != Cnil)
2295
@(return Cnil `make_fixnum(s)`)
2299
{char *tmp = OUR_ALLOCA(e-s);
2300
bcopy( strng->st.st_self+s,tmp,e-s);
2301
x = parse_integer(tmp, e-s, &ep, fix(radix));
2305
if (junk_allowed != Cnil)
2306
@(return Cnil `make_fixnum(ep+s)`)
2310
if (junk_allowed != Cnil)
2311
@(return x `make_fixnum(ep+s)`)
2312
for (s += ep ; s < e; s++)
2313
if (READtable->rt.rt_self[(unsigned char)strng->st.st_self[s]]
2317
@(return x `make_fixnum(e)`)
2320
Icall_error_handler(sKparse_error,
2321
make_simple_string("Cannot parse an integer in the string ~S."),
2325
@(defun read_byte (binary_input_stream
2326
&optional eof_errorp eof_value)
2329
check_type_stream(&binary_input_stream);
2330
if (stream_at_end(binary_input_stream)) {
2331
if (eof_errorp == Cnil)
2334
end_of_stream(binary_input_stream);
2336
c = readc_stream(binary_input_stream);
2337
@(return `make_fixnum(c)`)
2341
read_byte1(strm,eof)
2345
strm = symbol_value(sLAstandard_inputA);
2346
else if (strm == Ct)
2347
strm = symbol_value(sLAterminal_ioA);
2348
if (stream_at_end(strm))
2350
return make_fixnum(readc_stream(strm));
2354
read_char1(strm,eof)
2358
strm = symbol_value(sLAstandard_inputA);
2359
else if (strm == Ct)
2360
strm = symbol_value(sLAterminal_ioA);
2361
if (stream_at_end(strm))
2363
return code_char(readc_stream(strm));
2366
@(defun copy_readtable (&optional (from `current_readtable()`) to)
2369
from = standard_readtable;
2371
check_type_readtable(&to);
2372
to = copy_readtable(from, to);
2373
to->rt.rt_self['#'].rte_dtab['!']
2374
= default_dispatch_macro;
2375
/* We must forget #! macro. */
2378
check_type_readtable(&from);
2380
check_type_readtable(&to);
2381
@(return `copy_readtable(from, to)`)
2388
if (type_of(vs_base[0]) == t_readtable)
2394
@(defun set_syntax_from_char (tochr fromchr
2395
&optional (tordtbl `current_readtable()`)
2399
check_type_character(&tochr);
2400
check_type_character(&fromchr);
2401
check_type_readtable(&tordtbl);
2402
{BEGIN_NO_INTERRUPT;
2403
if (fromrdtbl == Cnil)
2404
fromrdtbl = standard_readtable;
2406
check_type_readtable(&fromrdtbl);
2407
tordtbl->rt.rt_self[char_code(tochr)].rte_chattrib
2408
= fromrdtbl->rt.rt_self[char_code(fromchr)].rte_chattrib;
2409
tordtbl->rt.rt_self[char_code(tochr)].rte_macro
2410
= fromrdtbl->rt.rt_self[char_code(fromchr)].rte_macro;
2411
if ((tordtbl->rt.rt_self[char_code(tochr)].rte_dtab
2412
= fromrdtbl->rt.rt_self[char_code(fromchr)].rte_dtab)
2414
tordtbl->rt.rt_self[char_code(tochr)].rte_dtab
2416
alloc_contblock(RTABSIZE * sizeof(object));
2417
for (i = 0; i < RTABSIZE; i++)
2418
tordtbl->rt.rt_self[char_code(tochr)]
2420
= fromrdtbl->rt.rt_self[char_code(fromchr)]
2427
@(defun set_macro_character (chr fnc
2429
(rdtbl `current_readtable()`))
2432
check_type_character(&chr);
2433
check_type_readtable(&rdtbl);
2436
rdtbl->rt.rt_self[c].rte_chattrib
2437
= cat_non_terminating;
2439
rdtbl->rt.rt_self[c].rte_chattrib
2441
rdtbl->rt.rt_self[c].rte_macro = fnc;
2445
@(defun get_macro_character (chr &optional (rdtbl `current_readtable()`))
2448
check_type_character(&chr);
2449
check_type_readtable(&rdtbl);
2450
if ((m = rdtbl->rt.rt_self[char_code(chr)].rte_macro)
2453
if (rdtbl->rt.rt_self[char_code(chr)].rte_chattrib
2454
== cat_non_terminating)
2460
@(static defun make_dispatch_macro_character (chr
2461
&optional ntp (rdtbl `current_readtable()`))
2464
check_type_character(&chr);
2465
check_type_readtable(&rdtbl);
2466
{BEGIN_NO_INTERRUPT;
2468
rdtbl->rt.rt_self[char_code(chr)].rte_chattrib
2469
= cat_non_terminating;
2471
rdtbl->rt.rt_self[char_code(chr)].rte_chattrib
2473
rdtbl->rt.rt_self[char_code(chr)].rte_dtab
2475
alloc_contblock(RTABSIZE * sizeof(object));
2476
for (i = 0; i < RTABSIZE; i++)
2477
rdtbl->rt.rt_self[char_code(chr)].rte_dtab[i]
2478
= default_dispatch_macro;
2479
rdtbl->rt.rt_self[char_code(chr)].rte_macro = dispatch_reader;
2484
@(static defun set_dispatch_macro_character (dspchr subchr fnc
2485
&optional (rdtbl `current_readtable()`))
2487
check_type_character(&dspchr);
2488
check_type_character(&subchr);
2489
check_type_readtable(&rdtbl);
2490
if (rdtbl->rt.rt_self[char_code(dspchr)].rte_macro != dispatch_reader
2491
|| rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab == NULL)
2492
FEerror("~S is not a dispatch character.", 1, dspchr);
2493
rdtbl->rt.rt_self[char_code(dspchr)]
2494
.rte_dtab[char_code(subchr)] = fnc;
2495
if ('a' <= char_code(subchr) && char_code(subchr) <= 'z')
2496
rdtbl->rt.rt_self[char_code(dspchr)]
2497
.rte_dtab[char_code(subchr) - ('a' - 'A')] = fnc;
2502
@(static defun get_dispatch_macro_character (dspchr subchr
2503
&optional (rdtbl `current_readtable()`))
2505
check_type_character(&dspchr);
2506
check_type_character(&subchr);
2507
check_type_readtable(&rdtbl);
2508
if (rdtbl->rt.rt_self[char_code(dspchr)].rte_macro != dispatch_reader
2509
|| rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab == NULL)
2510
FEerror("~S is not a dispatch character.", 1, dspchr);
2511
if (digitp(char_code(subchr),10) >= 0) @(return Cnil)
2512
else @(return `rdtbl->rt.rt_self[char_code(dspchr)]
2513
.rte_dtab[char_code(subchr)]`)
2523
in = make_string_input_stream(x, 0, x->st.st_fillp);
2525
preserving_whitespace_flag = FALSE;
2526
detect_eos_flag = FALSE;
2527
x = read_object_non_recursive(in);
2532
LFD(siLstring_to_object)()
2536
check_type_string(&vs_base[0]);
2537
vs_base[0] = string_to_object(vs_base[0]);
2542
FFN(siLstandard_readtable)()
2546
vs_push(standard_readtable);
2550
too_long_token(void)
2555
{BEGIN_NO_INTERRUPT;
2556
q = alloc_contblock(token->st.st_dim*2);
2557
for (i = 0; i < token->st.st_dim; i++)
2558
q[i] = token->st.st_self[i];
2559
token->st.st_self = q;
2560
token->st.st_dim *= 2;
2563
token->st.st_fillp = token->st.st_dim;
2564
FEerror("Too long a token: ~A.", 1, token);
2569
too_long_string(void)
2573
{BEGIN_NO_INTERRUPT;
2574
q = alloc_contblock(token->st.st_dim*2);
2575
for (i = 0; i < token->st.st_dim; i++)
2576
q[i] = token->st.st_self[i];
2577
token->st.st_self = q;
2578
token->st.st_dim *= 2;
2581
token->st.st_fillp = token->st.st_dim;
2582
FEerror("Too long a string: ~S.", 1, token);
2590
FEerror("~S is an extra argument for the #~C readmacro.",
2591
2, vs_base[2], code_char(c));
2595
#define make_cf(f) make_cfun((f), Cnil, Cnil, NULL, 0)
2597
DEFVAR("*READ-DEFAULT-FLOAT-FORMAT*",sLAread_default_float_formatA,
2598
LISP,sLsingle_float,"");
2599
DEFVAR("*READ-BASE*",sLAread_baseA,LISP,make_fixnum(10),"");
2600
DEFVAR("*READ-SUPPRESS*",sLAread_suppressA,LISP,Cnil,"");
2610
standard_readtable = alloc_object(t_readtable);
2611
enter_mark_origin(&standard_readtable);
2613
standard_readtable->rt.rt_self
2616
alloc_contblock(RTABSIZE * sizeof(struct rtent));
2617
for (i = 0; i < RTABSIZE; i++) {
2618
rtab[i].rte_chattrib = cat_constituent;
2619
rtab[i].rte_macro = OBJNULL;
2620
rtab[i].rte_dtab = NULL;
2623
dispatch_reader = make_cf(Ldispatch_reader);
2624
enter_mark_origin(&dispatch_reader);
2626
rtab['\t'].rte_chattrib = cat_whitespace;
2627
rtab['\n'].rte_chattrib = cat_whitespace;
2628
rtab['\f'].rte_chattrib = cat_whitespace;
2629
rtab['\r'].rte_chattrib = cat_whitespace;
2630
rtab[' '].rte_chattrib = cat_whitespace;
2631
rtab['"'].rte_chattrib = cat_terminating;
2632
rtab['"'].rte_macro = make_cf(Ldouble_quote_reader);
2633
rtab['#'].rte_chattrib = cat_non_terminating;
2634
rtab['#'].rte_macro = dispatch_reader;
2635
rtab['\''].rte_chattrib = cat_terminating;
2636
rtab['\''].rte_macro = make_cf(Lsingle_quote_reader);
2637
rtab['('].rte_chattrib = cat_terminating;
2638
rtab['('].rte_macro = make_cf(Lleft_parenthesis_reader);
2639
rtab[')'].rte_chattrib = cat_terminating;
2640
rtab[')'].rte_macro = make_cf(Lright_parenthesis_reader);
2642
rtab[','].rte_chattrib = cat_terminating;
2643
rtab[','].rte_macro = make_cf(Lcomma_reader);
2645
rtab[';'].rte_chattrib = cat_terminating;
2646
rtab[';'].rte_macro = make_cf(Lsemicolon_reader);
2647
rtab['\\'].rte_chattrib = cat_single_escape;
2649
rtab['`'].rte_chattrib = cat_terminating;
2650
rtab['`'].rte_macro = make_cf(Lbackquote_reader);
2652
rtab['|'].rte_chattrib = cat_multiple_escape;
2654
rtab['|'].rte_macro = make_cf(Lvertical_bar_reader);
2657
default_dispatch_macro = make_cf(Ldefault_dispatch_macro);
2661
= (object *)alloc_contblock(RTABSIZE * sizeof(object));
2662
for (i = 0; i < RTABSIZE; i++)
2663
dtab[i] = default_dispatch_macro;
2664
dtab['C'] = dtab['c'] = make_cf(Lsharp_C_reader);
2665
dtab['\\'] = make_cf(Lsharp_backslash_reader);
2666
dtab['\''] = make_cf(Lsharp_single_quote_reader);
2667
dtab['('] = make_cf(Lsharp_left_parenthesis_reader);
2668
dtab['*'] = make_cf(Lsharp_asterisk_reader);
2669
dtab[':'] = make_cf(Lsharp_colon_reader);
2670
dtab['.'] = make_cf(Lsharp_dot_reader);
2671
dtab['!'] = make_cf(Lsharp_exclamation_reader);
2672
/* Used for fasload only. */
2673
dtab[','] = make_cf(Lsharp_comma_reader);
2674
dtab['B'] = dtab['b'] = make_cf(Lsharp_B_reader);
2675
dtab['O'] = dtab['o'] = make_cf(Lsharp_O_reader);
2676
dtab['X'] = dtab['x'] = make_cf(Lsharp_X_reader);
2677
dtab['R'] = dtab['r'] = make_cf(Lsharp_R_reader);
2679
dtab['A'] = dtab['a'] = make_cf(Lsharp_A_reader);
2680
dtab['S'] = dtab['s'] = make_cf(Lsharp_S_reader);
2682
dtab['A'] = dtab['a'] = make_si_ordinary("SHARP-A-READER");
2683
dtab['S'] = dtab['s'] = make_si_ordinary("SHARP-S-READER");
2685
dtab['='] = make_cf(Lsharp_eq_reader);
2686
dtab['#'] = make_cf(Lsharp_sharp_reader);
2687
dtab['+'] = make_cf(Lsharp_plus_reader);
2688
dtab['-'] = make_cf(Lsharp_minus_reader);
2690
dtab['<'] = make_cf(Lsharp_less_than_reader);
2692
dtab['|'] = make_cf(Lsharp_vertical_bar_reader);
2693
dtab['"'] = make_cf(Lsharp_double_quote_reader);
2694
dtab['p'] = make_cf(Lsharp_p_reader);
2695
dtab['P'] = make_cf(Lsharp_p_reader);
2696
/* This is specific to this implimentation */
2697
dtab['$'] = make_cf(Lsharp_dollar_reader);
2698
/* This is specific to this implimentation */
2700
dtab[' '] = dtab['\t'] = dtab['\n'] = dtab['\f']
2701
= make_cf(Lsharp_whitespace_reader);
2702
dtab[')'] = make_cf(Lsharp_right_parenthesis_reader);
2708
= make_special("*READTABLE*",
2709
copy_readtable(standard_readtable, Cnil));
2710
Vreadtable->s.s_dbind->rt.rt_self['#'].rte_dtab['!']
2711
= default_dispatch_macro;
2712
/* We must forget #! macro. */
2715
sKstart = make_keyword("START");
2716
sKend = make_keyword("END");
2717
sKradix = make_keyword("RADIX");
2718
sKjunk_allowed = make_keyword("JUNK-ALLOWED");
2720
READtable = symbol_value(Vreadtable);
2721
enter_mark_origin(&READtable);
2722
READdefault_float_format = 'F';
2724
READsuppress = FALSE;
2726
sharp_eq_context_max = 0;
2728
siSsharp_comma = make_si_ordinary("#,");
2729
enter_mark_origin(&siSsharp_comma);
2731
delimiting_char = OBJNULL;
2732
enter_mark_origin(&delimiting_char);
2734
detect_eos_flag = FALSE;
2735
in_list_flag = FALSE;
2738
big_register_0 = new_bignum();
2739
zero_big(big_register_0);
2741
enter_mark_origin(&big_register_0);
2745
The value of big_register_0 changes
2746
along the execution of the read routines.
2751
gcl_init_read_function()
2753
make_function("READ", Lread);
2754
make_function("READ-PRESERVING-WHITESPACE",
2755
Lread_preserving_whitespace);
2756
make_function("READ-DELIMITED-LIST", Lread_delimited_list);
2757
make_function("READ-LINE", Lread_line);
2758
make_function("READ-CHAR", Lread_char);
2759
make_function("UNREAD-CHAR", Lunread_char);
2760
make_function("PEEK-CHAR", Lpeek_char);
2761
make_function("LISTEN", Llisten);
2762
make_function("READ-CHAR-NO-HANG", Lread_char_no_hang);
2763
make_function("CLEAR-INPUT", Lclear_input);
2765
make_function("PARSE-INTEGER", Lparse_integer);
2767
make_function("READ-BYTE", Lread_byte);
2769
make_function("COPY-READTABLE", Lcopy_readtable);
2770
make_function("READTABLEP", Lreadtablep);
2771
make_function("SET-SYNTAX-FROM-CHAR", Lset_syntax_from_char);
2772
make_function("SET-MACRO-CHARACTER", Lset_macro_character);
2773
make_function("GET-MACRO-CHARACTER", Lget_macro_character);
2774
make_function("MAKE-DISPATCH-MACRO-CHARACTER",
2775
Lmake_dispatch_macro_character);
2776
make_function("SET-DISPATCH-MACRO-CHARACTER",
2777
Lset_dispatch_macro_character);
2778
make_function("GET-DISPATCH-MACRO-CHARACTER",
2779
Lget_dispatch_macro_character);
2781
make_si_function("SHARP-COMMA-READER-FOR-COMPILER",
2782
siLsharp_comma_reader_for_compiler);
2784
make_si_function("STRING-TO-OBJECT", siLstring_to_object);
2786
make_si_function("STANDARD-READTABLE", siLstandard_readtable);
2792
read_fasl_vector1(in)
2801
object old_READtable;
2802
int old_READdefault_float_format;
2804
int old_READsuppress;
2805
int old_sharp_eq_context_max;
2806
struct sharp_eq_context_struct
2807
old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
2808
int old_backq_level;
2810
/* to prevent longjmp clobber */
2813
old_READtable = READtable;
2814
old_READdefault_float_format = READdefault_float_format;
2815
old_READbase = READbase;
2816
old_READsuppress = READsuppress;
2817
old_sharp_eq_context_max = sharp_eq_context_max;
2818
/* BUG FIX by Toshiba */
2819
vs_push(old_READtable);
2820
for (i = 0; i < sharp_eq_context_max; i++)
2821
old_sharp_eq_context[i] = sharp_eq_context[i];
2822
old_backq_level = backq_level;
2824
setup_standard_READ();
2826
frs_push(FRS_PROTECT, Cnil);
2832
while (readc_stream(in) != '#')
2834
while (readc_stream(in) != '(')
2839
sharp_eq_context_max = 0;
2841
delimiting_char = code_char(')');
2842
preserving_whitespace_flag = FALSE;
2843
detect_eos_flag = FALSE;
2844
x = read_object(in);
2848
if (sharp_eq_context_max > 0)
2849
x = vs_head = patch_sharp(x);
2852
if(dimcount==1 && type_of(vs_head)==t_vector)
2853
{/* new style where all read at once */
2856
/* old style separately sharped, and no %init */
2857
{BEGIN_NO_INTERRUPT;
2858
x=alloc_simple_vector(dimcount,aet_object);
2861
= (object *)alloc_relblock(dimcount * sizeof(object));
2863
for (dim = 0; dim < dimcount; dim++)
2865
x->cfd.cfd_self[dim] = vsp[dim];}
2874
READtable = old_READtable;
2875
READdefault_float_format = old_READdefault_float_format;
2876
READbase = old_READbase;
2877
READsuppress = old_READsuppress;
2878
sharp_eq_context_max = old_sharp_eq_context_max;
2879
for (i = 0; i < sharp_eq_context_max; i++)
2880
sharp_eq_context[i] = old_sharp_eq_context[i];
2881
backq_level = old_backq_level;
2884
unwind(nlj_fr, nlj_tag);
2886
vs_top = (object *)vsp;
added
removed
o/read.d
