48 |
|
|
49 |
#define cat(c) (READtable->rt.rt_self[char_code((c))] \ |
#define cat(c) (READtable->rt.rt_self[char_code((c))] \ |
50 |
.rte_chattrib) |
.rte_chattrib) |
51 |
|
#define trt(c) (READtable->rt.rt_self[char_code((c))] \ |
52 |
|
.rte_chatrait) |
53 |
|
|
54 |
#ifndef SHARP_EQ_CONTEXT_SIZE |
#ifndef SHARP_EQ_CONTEXT_SIZE |
55 |
#define SHARP_EQ_CONTEXT_SIZE 500 |
#define SHARP_EQ_CONTEXT_SIZE 500 |
75 |
*/ |
*/ |
76 |
|
|
77 |
|
|
78 |
|
/* FIXME What should this be? Apparently no reliable way to use value stack */ |
79 |
|
#define MAX_PACKAGE_STACK 1024 |
80 |
|
static object P0[MAX_PACKAGE_STACK],*PP0=P0,LP; |
81 |
|
|
82 |
static void |
static void |
83 |
setup_READ() |
setup_READ() |
84 |
{ |
{ |
107 |
sharp_eq_context_max = 0; |
sharp_eq_context_max = 0; |
108 |
|
|
109 |
backq_level = 0; |
backq_level = 0; |
110 |
|
|
111 |
|
PP0=P0; |
112 |
|
LP=NULL; |
113 |
|
|
114 |
} |
} |
115 |
|
|
116 |
static void |
static void |
406 |
This routine corresponds to COMMON Lisp function READ. |
This routine corresponds to COMMON Lisp function READ. |
407 |
*/ |
*/ |
408 |
|
|
|
/* FIXME What should this be? Apparently no reliable way to use value stack */ |
|
|
#define MAX_PACKAGE_STACK 1024 |
|
|
static object P0[MAX_PACKAGE_STACK],*PP0=P0,LP; |
|
|
|
|
409 |
object |
object |
410 |
read_object(in) |
read_object(in) |
411 |
object in; |
object in; |
437 |
if (df) { |
if (df) { |
438 |
vs_reset; |
vs_reset; |
439 |
return(OBJNULL); |
return(OBJNULL); |
440 |
} else |
} else |
441 |
end_of_stream(in); |
end_of_stream(in); |
442 |
}); |
}); |
443 |
a = cat(c); |
a = cat(c); |
444 |
} while (a == cat_whitespace); |
} while (a == cat_whitespace); |
445 |
if (c->ch.ch_code == '(') { /* Loose package extension */ |
|
|
LP=LP || PP0==P0 ? LP : PP0[-1]; /* push loose packages into nested lists */ |
|
|
if (LP) { |
|
|
if (PP0-P0>=MAX_PACKAGE_STACK) |
|
|
FEerror("Too many nested package specifiers",0); |
|
|
*PP0++=LP; |
|
|
LP=NULL; |
|
|
} |
|
|
} else if (LP) |
|
|
FEerror("Loose package prefix must be followed by a list",0); |
|
|
if (c->ch.ch_code==')' && PP0>P0) PP0--; /* regardless of error behavior, |
|
|
will pop stack to beginning as parens |
|
|
must match before the reader starts */ |
|
446 |
delimiting_char = vs_head; |
delimiting_char = vs_head; |
447 |
if (delimiting_char != OBJNULL && c == delimiting_char) { |
if (delimiting_char != OBJNULL && c == delimiting_char) { |
448 |
delimiting_char = OBJNULL; |
delimiting_char = OBJNULL; |
449 |
vs_reset; |
vs_reset; |
450 |
|
LP=NULL; |
451 |
return(OBJNULL); |
return(OBJNULL); |
452 |
} |
} |
453 |
delimiting_char = OBJNULL; |
delimiting_char = OBJNULL; |
466 |
fun_box[0] = x; |
fun_box[0] = x; |
467 |
super_funcall(x); |
super_funcall(x); |
468 |
|
|
469 |
|
LP=NULL; |
470 |
i = vs_top - vs_base; |
i = vs_top - vs_base; |
471 |
if (i == 0) { |
if (i == 0) { |
472 |
vs_base = old_vs_base; |
vs_base = old_vs_base; |
524 |
goto K; |
goto K; |
525 |
else |
else |
526 |
break; |
break; |
527 |
} |
} else { |
528 |
else if ('a' <= char_code(c) && char_code(c) <= 'z') |
|
529 |
c = code_char(char_code(c) - ('a' - 'A')); |
if (trt(c)==trait_invalid) |
530 |
else if (char_code(c) == ':') { |
READER_ERROR("Cannot read character"); |
531 |
if (colon_type == 0) { |
|
532 |
colon_type = 1; |
if ('A' <= char_code(c) && char_code(c) <= 'z') { |
533 |
colon = length; |
if ('a' <= char_code(c) && char_code(c) <= 'z' && |
534 |
} else if (colon_type == 1 && colon == length-1) |
(READtable->rt.rt_case==sKupcase || READtable->rt.rt_case==sKinvert)) |
535 |
colon_type = 2; |
c = code_char(char_code(c) - ('a' - 'A')); |
536 |
else |
else if ('A' <= char_code(c) && char_code(c) <= 'Z' && |
537 |
colon_type = -1; |
(READtable->rt.rt_case==sKdowncase || READtable->rt.rt_case==sKinvert)) |
538 |
/* Colon has appeared twice. */ |
c = code_char(char_code(c) + ('a' - 'A')); |
539 |
|
} else if (char_code(c) == ':') { |
540 |
|
if (colon_type == 0) { |
541 |
|
colon_type = 1; |
542 |
|
colon = length; |
543 |
|
} else if (colon_type == 1 && colon == length-1) |
544 |
|
colon_type = 2; |
545 |
|
else |
546 |
|
colon_type = -1; |
547 |
|
/* Colon has appeared twice. */ |
548 |
|
} |
549 |
} |
} |
550 |
} |
} |
551 |
if (preserving_whitespace_flag || cat(c) != cat_whitespace) |
if (preserving_whitespace_flag || cat(c) != cat_whitespace) |
644 |
return(x); |
return(x); |
645 |
} |
} |
646 |
|
|
647 |
|
static int inlp; |
648 |
|
|
649 |
static void |
static void |
650 |
Lleft_parenthesis_reader() |
Lleft_parenthesis_reader() |
651 |
{ |
{ |
656 |
in = vs_base[0]; |
in = vs_base[0]; |
657 |
vs_head = Cnil; |
vs_head = Cnil; |
658 |
p = &vs_head; |
p = &vs_head; |
659 |
|
inlp=1; |
660 |
|
LP=LP || PP0==P0 ? LP : PP0[-1]; /* push loose packages into nested lists */ |
661 |
|
if (LP) { |
662 |
|
if (PP0-P0>=MAX_PACKAGE_STACK) |
663 |
|
FEerror("Too many nested package specifiers",0); |
664 |
|
*PP0++=LP; |
665 |
|
LP=NULL; |
666 |
|
} |
667 |
for (;;) { |
for (;;) { |
668 |
delimiting_char = code_char(')'); |
delimiting_char = code_char(')'); |
669 |
in_list_flag = TRUE; |
in_list_flag = TRUE; |
682 |
c = read_char(in); |
c = read_char(in); |
683 |
if (char_code(c) != ')') |
if (char_code(c) != ')') |
684 |
FEerror("A dot appeared before a right parenthesis.", 0); |
FEerror("A dot appeared before a right parenthesis.", 0); |
|
else if (PP0>P0) PP0--; /* should be the only other place |
|
|
outside of read_object where |
|
|
closing parens are read */ |
|
685 |
goto ENDUP; |
goto ENDUP; |
686 |
} |
} |
687 |
vs_push(x); |
vs_push(x); |
691 |
} |
} |
692 |
|
|
693 |
ENDUP: |
ENDUP: |
694 |
|
if (PP0>P0) PP0--; |
695 |
vs_base[0] = vs_pop; |
vs_base[0] = vs_pop; |
696 |
|
inlp=0; |
697 |
return; |
return; |
698 |
} |
} |
699 |
|
|
1075 |
static void |
static void |
1076 |
Ldouble_quote_reader() |
Ldouble_quote_reader() |
1077 |
{ |
{ |
1078 |
check_arg(2); |
object c; |
1079 |
vs_popp; |
check_arg(2); |
1080 |
read_string('"', vs_base[0]); |
c=vs_base[1]; |
1081 |
vs_base[0] = copy_simple_string(token); |
vs_popp; |
1082 |
|
read_string(char_code(c), vs_base[0]); |
1083 |
|
vs_base[0] = copy_simple_string(token); |
1084 |
|
|
1085 |
} |
} |
1086 |
|
|
1087 |
static void |
static void |
1141 |
Lright_parenthesis_reader() |
Lright_parenthesis_reader() |
1142 |
{ |
{ |
1143 |
check_arg(2); |
check_arg(2); |
1144 |
|
if (!inlp) |
1145 |
|
READER_ERROR("Right paren found with no left."); |
1146 |
vs_popp; |
vs_popp; |
1147 |
vs_popp; |
vs_popp; |
1148 |
/* no result */ |
/* no result */ |
1880 |
static void |
static void |
1881 |
Ldefault_dispatch_macro() |
Ldefault_dispatch_macro() |
1882 |
{ |
{ |
1883 |
FEerror("The default dispatch macro signalled an error.", 0); |
READER_ERROR("The default dispatch macro signalled an error."); |
1884 |
} |
} |
1885 |
|
|
1886 |
/* |
/* |
1980 |
rtab[i].rte_dtab[j] |
rtab[i].rte_dtab[j] |
1981 |
= from->rt.rt_self[i].rte_dtab[j]; |
= from->rt.rt_self[i].rte_dtab[j]; |
1982 |
} |
} |
1983 |
|
to->rt.rt_case=from->rt.rt_case; |
1984 |
vs_reset; |
vs_reset; |
1985 |
END_NO_INTERRUPT;} |
END_NO_INTERRUPT;} |
1986 |
return(to); |
return(to); |
2430 |
fromrdtbl = standard_readtable; |
fromrdtbl = standard_readtable; |
2431 |
else |
else |
2432 |
check_type_readtable(&fromrdtbl); |
check_type_readtable(&fromrdtbl); |
2433 |
tordtbl->rt.rt_self[char_code(tochr)].rte_chattrib |
tordtbl->rt.rt_self[char_code(tochr)].rte_chattrib |
2434 |
= fromrdtbl->rt.rt_self[char_code(fromchr)].rte_chattrib; |
= fromrdtbl->rt.rt_self[char_code(fromchr)].rte_chattrib; |
2435 |
tordtbl->rt.rt_self[char_code(tochr)].rte_macro |
tordtbl->rt.rt_self[char_code(tochr)].rte_macro |
2436 |
= fromrdtbl->rt.rt_self[char_code(fromchr)].rte_macro; |
= fromrdtbl->rt.rt_self[char_code(fromchr)].rte_macro; |
2437 |
if ((tordtbl->rt.rt_self[char_code(tochr)].rte_dtab |
if ((tordtbl->rt.rt_self[char_code(tochr)].rte_dtab |
2525 |
@(return Ct) |
@(return Ct) |
2526 |
@) |
@) |
2527 |
|
|
2528 |
|
DEFUNO_NEW("READTABLE-CASE",object,fLreadtable_case,LISP,1,1,NONE,OO,OO,OO,OO,void,Lreadtable_case,(object rt),"") { |
2529 |
|
check_type_readtable_no_default(&rt); |
2530 |
|
RETURN1(rt->rt.rt_case); |
2531 |
|
} |
2532 |
|
|
2533 |
|
DEFUNO_NEW("SET-READTABLE-CASE",object,fSset_readtable_case,SI,2,2,NONE, |
2534 |
|
OO,OO,OO,OO,void,siLset_readtable_case,(object rt,object cas),"") { |
2535 |
|
check_type_readtable_no_default(&rt); |
2536 |
|
if (cas!=sKupcase && cas!=sKdowncase && cas!=sKpreserve && cas!=sKinvert) |
2537 |
|
TYPE_ERROR(cas,list(5,sLmember,sKupcase,sKdowncase,sKpreserve,sKinvert)); |
2538 |
|
RETURN1(rt->rt.rt_case=cas); |
2539 |
|
} |
2540 |
|
|
2541 |
|
|
2542 |
|
|
2543 |
@(static defun get_dispatch_macro_character (dspchr subchr |
@(static defun get_dispatch_macro_character (dspchr subchr |
2544 |
&optional (rdtbl `current_readtable()`)) |
&optional (rdtbl `current_readtable()`)) |
2545 |
@ |
@ |
2664 |
dispatch_reader = make_cf(Ldispatch_reader); |
dispatch_reader = make_cf(Ldispatch_reader); |
2665 |
enter_mark_origin(&dispatch_reader); |
enter_mark_origin(&dispatch_reader); |
2666 |
|
|
2667 |
|
|
2668 |
|
rtab['\b'].rte_chatrait = trait_invalid; |
2669 |
|
rtab['\t'].rte_chatrait = trait_invalid; |
2670 |
|
rtab['\n'].rte_chatrait = trait_invalid; |
2671 |
|
rtab['\r'].rte_chatrait = trait_invalid; |
2672 |
|
rtab['\f'].rte_chatrait = trait_invalid; |
2673 |
|
rtab[' '].rte_chatrait = trait_invalid; |
2674 |
|
rtab['\177'].rte_chatrait = trait_invalid; |
2675 |
|
|
2676 |
|
|
2677 |
rtab['\t'].rte_chattrib = cat_whitespace; |
rtab['\t'].rte_chattrib = cat_whitespace; |
2678 |
|
rtab['\r'].rte_chattrib = cat_whitespace; |
2679 |
rtab['\n'].rte_chattrib = cat_whitespace; |
rtab['\n'].rte_chattrib = cat_whitespace; |
2680 |
rtab['\f'].rte_chattrib = cat_whitespace; |
rtab['\f'].rte_chattrib = cat_whitespace; |
|
rtab['\r'].rte_chattrib = cat_whitespace; |
|
2681 |
rtab[' '].rte_chattrib = cat_whitespace; |
rtab[' '].rte_chattrib = cat_whitespace; |
2682 |
rtab['"'].rte_chattrib = cat_terminating; |
rtab['"'].rte_chattrib = cat_terminating; |
2683 |
rtab['"'].rte_macro = make_cf(Ldouble_quote_reader); |
rtab['"'].rte_macro = make_cf(Ldouble_quote_reader); |
2755 |
|
|
2756 |
gcl_init_backq(); |
gcl_init_backq(); |
2757 |
|
|
2758 |
|
sKupcase = make_keyword("UPCASE"); |
2759 |
|
sKdowncase = make_keyword("DOWNCASE"); |
2760 |
|
sKpreserve = make_keyword("PRESERVE"); |
2761 |
|
sKinvert = make_keyword("INVERT"); |
2762 |
|
|
2763 |
|
standard_readtable->rt.rt_case=sKupcase; |
2764 |
|
|
2765 |
Vreadtable |
Vreadtable |
2766 |
= make_special("*READTABLE*", |
= make_special("*READTABLE*", |
2767 |
copy_readtable(standard_readtable, Cnil)); |
copy_readtable(standard_readtable, Cnil)); |