mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-12 07:50:26 -07:00
Code Issues Projects Releases Packages Wiki Activity

reader: store separately macro and a dispatch table

Browse source 
This improves code readibility, because dispatch macro characters are built on
top of "normal" macro characters.
This commit is contained in:
Daniel Kochmański 2026-03-05 22:04:47 +01:00
parent 4be70d8b1d
commit f0046250f8
8 changed files with 103 additions and 102 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/c/printer/write_symbol.d
View file

@ -89,7 +89,7 @@ needs_to_be_escaped(cl_object s, cl_object readtable, cl_object print_case)
* of 22.1.3.3.2. */
for (i = 0; i < s->base_string.fillp; i++) {
int c = ecl_char(s, i);
int syntax = ecl_readtable_get(readtable, c, 0);
int syntax = ecl_readtable_get(readtable, c, NULL, NULL);
if (syntax != cat_constituent ||
ecl_invalid_character_p(c) ||
(c) == ':')

6
src/c/read.d
View file

@ -168,7 +168,7 @@ ecl_read_constituent(cl_object in, bool not_first)
if (c == EOF) {
break;
}
c_cat = ecl_readtable_get(rtbl, c, NULL);
c_cat = ecl_readtable_get(rtbl, c, NULL, NULL);
if (c_cat == cat_constituent ||
((c_cat == cat_non_terminating) && not_first))
{
@ -384,7 +384,7 @@ stream_or_default_input(cl_object stream)
if (Null(recursivep)) {
cl_object rtbl = ecl_current_readtable();
int c = ecl_read_char(strm);
if (c != EOF && (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace)) {
if (c != EOF && (ecl_readtable_get(rtbl, c, NULL, NULL) != cat_whitespace)) {
ecl_unread_char(c, strm);
}
}
@ -556,7 +556,7 @@ ecl_read_delimited_list(int d, cl_object in, bool proper_list)
if (peek_type == ECL_T) {
do {
/* If the character is not a whitespace, output */
if (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace)
if (ecl_readtable_get(rtbl, c, NULL, NULL) != cat_whitespace)
break;
/* Otherwise, read the whitespace and peek the
* next character */

65
src/c/reader.d
View file

@ -98,50 +98,6 @@ invert_buffer_case(cl_object o, int sign)
} end_loop_across_token();
}
/*
Returns OBJNULL if no dispatch function is defined and signal_error is false.
*/
static cl_object
dispatch_macro_character(cl_object table, cl_object in, int c, bool signal_error)
{
cl_object arg;
int d;
c = ecl_read_char_noeof(in);
d = ecl_digitp(c, 10);
if (d >= 0) {
cl_fixnum i = 0;
do {
i = 10*i + d;
c = ecl_read_char_noeof(in);
d = ecl_digitp(c, 10);
} while (d >= 0);
arg = ecl_make_fixnum(i);
} else {
arg = ECL_NIL;
}
{
cl_object dc = ECL_CODE_CHAR(c);
cl_object fun = ecl_gethash_safe(dc, table, ECL_NIL);
unlikely_if (Null(fun)) {
if (!signal_error) return OBJNULL;
FEreader_error("No dispatch function defined for character ~S", in, 1, dc);
}
return _ecl_funcall4(fun, in, dc, arg);
}
}
cl_object
ecl_dispatch_reader_fun(cl_object in, cl_object dc)
{
cl_object readtable = ecl_current_readtable();
cl_object dispatch_table;
int c = ecl_char_code(dc);
ecl_readtable_get(readtable, c, &dispatch_table);
unlikely_if (!ECL_HASH_TABLE_P(dispatch_table))
FEreader_error("~C is not a dispatching macro character", in, 1, dc);
return dispatch_macro_character(dispatch_table, in, c, TRUE);
}
cl_object
ecl_read_token(cl_object rtbl, cl_object in, int flags)
{
@ -167,7 +123,7 @@ ecl_read_token(cl_object rtbl, cl_object in, int flags)
a = cat_single_escape;
} else {
c = ecl_read_char_noeof(in);
a = ecl_readtable_get(rtbl, c, NULL);
a = ecl_readtable_get(rtbl, c, NULL, NULL);
}
for (;;) {
@ -184,7 +140,7 @@ ecl_read_token(cl_object rtbl, cl_object in, int flags)
cl_index begin = length;
for (;;) {
c = ecl_read_char_noeof(in);
a = ecl_readtable_get(rtbl, c, NULL);
a = ecl_readtable_get(rtbl, c, NULL, NULL);
if (a == cat_single_escape) {
c = ecl_read_char_noeof(in);
a = cat_constituent;
@ -223,7 +179,7 @@ ecl_read_token(cl_object rtbl, cl_object in, int flags)
c = ecl_read_char(in);
if (c == EOF)
break;
a = ecl_readtable_get(rtbl, c, NULL);
a = ecl_readtable_get(rtbl, c, NULL, NULL);
}
token->token.escaped = (TOKEN_ESCAPE_FILLP(escape) > 0);
@ -258,21 +214,10 @@ ecl_read_object_with_delimiter(cl_object rtbl, cl_object in, int delimiter, int
}
if (c == EOF)
FEend_of_file(in);
a = ecl_readtable_get(rtbl, c, &x);
a = ecl_readtable_get(rtbl, c, &x, NULL);
} while (a == cat_whitespace);
if ((a == cat_terminating || a == cat_non_terminating)) {
cl_object o;
if (ECL_HASH_TABLE_P(x)) {
if (suppress) {
o = dispatch_macro_character(x, in, c, FALSE);
if (o == OBJNULL)
goto BEGIN;
} else {
o = dispatch_macro_character(x, in, c, TRUE);
}
} else {
o = _ecl_funcall3(x, in, ECL_CODE_CHAR(c));
}
cl_object o = _ecl_funcall3(x, in, ECL_CODE_CHAR(c));
if (the_env->nvalues == 0) {
if (flags & ECL_READ_RETURN_IGNORABLE)
return ECL_NIL;

4
src/c/reader/parse_integer.d
View file

@ -81,7 +81,7 @@ ecl_parse_integer(cl_object str, cl_index start, cl_index end,
e = p.end;
}
while (s < e &&
ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) == cat_whitespace) {
ecl_readtable_get(rtbl, ecl_char(strng, s), NULL, NULL) == cat_whitespace) {
s++;
}
if (s >= e) {
@ -104,7 +104,7 @@ ecl_parse_integer(cl_object str, cl_index start, cl_index end,
@(return x ecl_make_fixnum(ep));
}
for (s = ep; s < e; s++) {
unlikely_if (ecl_readtable_get(rtbl, ecl_char(strng, s), NULL)
unlikely_if (ecl_readtable_get(rtbl, ecl_char(strng, s), NULL, NULL)
!= cat_whitespace)
{
CANNOT_PARSE: FEparse_error("Cannot parse an integer in the string ~S.",

66
src/c/reader/rtab_cl.d
View file

@ -91,7 +91,7 @@ read_string_into_buffer(cl_object in, cl_object c, cl_object buffer)
int c = ecl_read_char_noeof(in);
if (c == delim)
break;
else if (ecl_readtable_get(rtbl, c, NULL) == cat_single_escape)
else if (ecl_readtable_get(rtbl, c, NULL, NULL) == cat_single_escape)
c = ecl_read_char_noeof(in);
ecl_string_push_extend(buffer, c);
}
@ -462,7 +462,7 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d)
int x = ecl_read_char(in);
if (x == EOF)
break;
a = ecl_readtable_get(rtbl, x, NULL);
a = ecl_readtable_get(rtbl, x, NULL, NULL);
if (a == cat_terminating || a == cat_whitespace) {
ecl_unread_char(x, in);
break;
@ -513,7 +513,7 @@ sharp_colon_reader(cl_object in, cl_object ch, cl_object d)
if (d != ECL_NIL && !read_suppress)
extra_argument(':', in, d);
c = ecl_read_char_noeof(in);
a = ecl_readtable_get(rtbl, c, NULL);
a = ecl_readtable_get(rtbl, c, NULL, NULL);
token = si_get_buffer_string();
goto L;
for (;;) {
@ -522,7 +522,7 @@ sharp_colon_reader(cl_object in, cl_object ch, cl_object d)
c = ecl_read_char(in);
if (c == EOF)
goto M;
a = ecl_readtable_get(rtbl, c, NULL);
a = ecl_readtable_get(rtbl, c, NULL, NULL);
L:
if (a == cat_single_escape) {
c = ecl_read_char_noeof(in);
@ -530,7 +530,7 @@ sharp_colon_reader(cl_object in, cl_object ch, cl_object d)
} else if (a == cat_multiple_escape) {
for (;;) {
c = ecl_read_char_noeof(in);
a = ecl_readtable_get(rtbl, c, NULL);
a = ecl_readtable_get(rtbl, c, NULL, NULL);
if (a == cat_single_escape) {
c = ecl_read_char_noeof(in);
a = cat_constituent;
@ -750,6 +750,52 @@ sharp_dollar_reader(cl_object in, cl_object c, cl_object d)
@(return rs);
}
/* Dispatch macro character funciton. */
static cl_object
dispatch_macro_character(cl_object table, cl_object in, int c)
{
const cl_env_ptr the_env = ecl_process_env();
cl_object arg;
int d;
c = ecl_read_char_noeof(in);
d = ecl_digitp(c, 10);
if (d >= 0) {
cl_fixnum i = 0;
do {
i = 10*i + d;
c = ecl_read_char_noeof(in);
d = ecl_digitp(c, 10);
} while (d >= 0);
arg = ecl_make_fixnum(i);
} else {
arg = ECL_NIL;
}
{
cl_object dc = ECL_CODE_CHAR(c);
cl_object fun = ecl_gethash_safe(dc, table, ECL_NIL);
unlikely_if (Null(fun)) {
if(read_suppress)
ecl_return0(the_env);
FEreader_error("No dispatch function defined for character ~S",
in, 1, ECL_CODE_CHAR(c));
}
return _ecl_funcall4(fun, in, dc, arg);
}
}
cl_object
ecl_dispatch_reader_fun(cl_object in, cl_object dc)
{
cl_object readtable = ecl_current_readtable();
cl_object dispatch_table;
int c = ecl_char_code(dc);
ecl_readtable_get(readtable, c, NULL, &dispatch_table);
unlikely_if (!ECL_HASH_TABLE_P(dispatch_table))
FEreader_error("~C is not a dispatching macro character", in, 1, dc);
return dispatch_macro_character(dispatch_table, in, c);
}
#define make_cf2(f) ecl_make_cfun((cl_objectfn_fixed)(f), ECL_NIL, NULL, 2)
#define make_cf3(f) ecl_make_cfun((cl_objectfn_fixed)(f), ECL_NIL, NULL, 3)
@ -768,7 +814,8 @@ init_read(void)
ecl_alloc(RTABSIZE * sizeof(struct ecl_readtable_entry));
for (i = 0; i < RTABSIZE; i++) {
rtab[i].syntax_type = cat_constituent;
rtab[i].dispatch = ECL_NIL;
rtab[i].macro = ECL_NIL;
rtab[i].table = ECL_NIL;
}
#ifdef ECL_UNICODE
r->readtable.hash = ECL_NIL;
@ -777,9 +824,10 @@ init_read(void)
cl_core.dispatch_reader = make_cf2(ecl_dispatch_reader_fun);
sharp_generic_error_fn = make_cf3(sharp_generic_error);
#define def_ch1_spc(ch) ecl_readtable_set(r, ch, cat_whitespace, ECL_NIL)
#define def_ch1_esc(ch,attr) ecl_readtable_set(r, ch, attr, ECL_NIL)
#define def_ch1_trm(ch,f) ecl_readtable_set(r, ch, cat_terminating, make_cf2(f))
#define def_ch1_spc(ch) ecl_readtable_set(r, ch, cat_whitespace, ECL_NIL, ECL_NIL)
#define def_ch1_esc(ch,attr) ecl_readtable_set(r, ch, attr, ECL_NIL, ECL_NIL)
#define def_ch1_trm(ch,f) ecl_readtable_set \
(r, ch, cat_terminating, make_cf2(f), ECL_NIL)
def_ch1_spc('\t');
def_ch1_spc('\n');

55
src/c/readtable.d
View file

@ -54,11 +54,11 @@ ecl_copy_readtable(cl_object from, cl_object to)
from_rtab = from->readtable.table;
memcpy(to_rtab, from_rtab, total_bytes);
for (i = 0; i < RTABSIZE; i++) {
cl_object d = from_rtab[i].dispatch;
cl_object d = from_rtab[i].table;
if (ECL_HASH_TABLE_P(d)) {
d = si_copy_hash_table(d);
}
to_rtab[i].dispatch = d;
to_rtab[i].table = d;
}
output->readtable.read_case = from->readtable.read_case;
#ifdef ECL_UNICODE
@ -150,9 +150,9 @@ cl_readtablep(cl_object readtable)
}
int
ecl_readtable_get(cl_object readtable, int c, cl_object *macro_or_table)
ecl_readtable_get(cl_object readtable, int c, cl_object *macro, cl_object *table)
{
cl_object m;
cl_object m, t;
enum ecl_chattrib cat;
#ifdef ECL_UNICODE
if (c >= RTABSIZE) {
@ -163,22 +163,27 @@ ecl_readtable_get(cl_object readtable, int c, cl_object *macro_or_table)
cl_object pair = ecl_gethash_safe(ECL_CODE_CHAR(c), hash, ECL_NIL);
if (!Null(pair)) {
cat = ecl_fixnum(ECL_CONS_CAR(pair));
m = ECL_CONS_CDR(pair);
pair = ECL_CONS_CDR(pair);
m = ECL_CONS_CAR(pair);
pair = ECL_CONS_CDR(pair);
t = ECL_CONS_CAR(pair);
}
}
} else
#endif
{
m = readtable->readtable.table[c].dispatch;
m = readtable->readtable.table[c].macro;
t = readtable->readtable.table[c].table;
cat = readtable->readtable.table[c].syntax_type;
}
if (macro_or_table) *macro_or_table = m;
if (macro) *macro = m;
if (table) *table = t;
return cat;
}
void
ecl_readtable_set(cl_object readtable, int c, enum ecl_chattrib cat,
cl_object macro_or_table)
cl_object macro, cl_object table)
{
if (readtable->readtable.locked) {
error_locked_readtable(readtable);
@ -193,11 +198,14 @@ ecl_readtable_set(cl_object readtable, int c, enum ecl_chattrib cat,
readtable->readtable.hash = hash;
}
_ecl_sethash(ECL_CODE_CHAR(c), hash,
CONS(ecl_make_fixnum(cat), macro_or_table));
CONS(ecl_make_fixnum(cat),
CONS(macro,
CONS(table, ECL_NIL))));
} else
#endif
{
readtable->readtable.table[c].dispatch = macro_or_table;
readtable->readtable.table[c].macro = macro;
readtable->readtable.table[c].table = table;
readtable->readtable.table[c].syntax_type = cat;
}
}
@ -214,7 +222,7 @@ ecl_invalid_character_p(int c)
&o (tordtbl ecl_current_readtable())
fromrdtbl)
enum ecl_chattrib cat;
cl_object dispatch;
cl_object macro, table;
cl_fixnum fc, tc;
@
if (tordtbl->readtable.locked) {
@ -227,11 +235,11 @@ ecl_invalid_character_p(int c)
fc = ecl_char_code(fromchr);
tc = ecl_char_code(tochr);
cat = ecl_readtable_get(fromrdtbl, fc, &dispatch);
if (ECL_HASH_TABLE_P(dispatch)) {
dispatch = si_copy_hash_table(dispatch);
cat = ecl_readtable_get(fromrdtbl, fc, &macro, &table);
if (ECL_HASH_TABLE_P(table)) {
table = si_copy_hash_table(table);
}
ecl_readtable_set(tordtbl, tc, cat, dispatch);
ecl_readtable_set(tordtbl, tc, cat, macro, table);
@(return ECL_T);
@)
@ -242,20 +250,19 @@ ecl_invalid_character_p(int c)
Null(non_terminating_p)?
cat_terminating :
cat_non_terminating,
function);
function,
ECL_NIL);
@(return ECL_T);
@)
@(defun get_macro_character (c &optional (readtable ecl_current_readtable()))
enum ecl_chattrib cat;
cl_object dispatch;
cl_object macro;
@
if (Null(readtable))
readtable = cl_core.standard_readtable;
cat = ecl_readtable_get(readtable, ecl_char_code(c), &dispatch);
if (ECL_HASH_TABLE_P(dispatch))
dispatch = cl_core.dispatch_reader;
@(return dispatch ((cat == cat_non_terminating)? ECL_T : ECL_NIL));
cat = ecl_readtable_get(readtable, ecl_char_code(c), &macro, NULL);
@(return macro ((cat == cat_non_terminating)? ECL_T : ECL_NIL));
@)
@(defun make_dispatch_macro_character (chr
@ -270,7 +277,7 @@ ecl_invalid_character_p(int c)
table = cl__make_hash_table(@'eql', ecl_make_fixnum(128),
ecl_ct_default_rehash_size,
ecl_ct_default_rehash_threshold);
ecl_readtable_set(readtable, c, cat, table);
ecl_readtable_set(readtable, c, cat, cl_core.dispatch_reader, table);
@(return ECL_T);
@)
@ -280,7 +287,7 @@ ecl_invalid_character_p(int c)
cl_fixnum subcode;
@
assert_type_readtable(@[set-dispatch-macro-character], 4, readtable);
ecl_readtable_get(readtable, ecl_char_code(dspchr), &table);
ecl_readtable_get(readtable, ecl_char_code(dspchr), NULL, &table);
unlikely_if (readtable->readtable.locked) {
error_locked_readtable(readtable);
}
@ -316,7 +323,7 @@ ecl_invalid_character_p(int c)
}
assert_type_readtable(@[get-dispatch-macro-character], 3, readtable);
c = ecl_char_code(dspchr);
ecl_readtable_get(readtable, c, &table);
ecl_readtable_get(readtable, c, NULL, &table);
unlikely_if (!ECL_HASH_TABLE_P(table)) {
FEerror("~S is not a dispatch character.", 1, dspchr);
}

4
src/h/external.h
View file

@ -1570,8 +1570,8 @@ extern ECL_API cl_object si_read_object_or_ignore(cl_object stream, cl_object eo
extern ECL_API cl_object si_readtable_lock _ECL_ARGS((cl_narg narg, cl_object readtable, ...));
extern ECL_API cl_object si_make_backq_vector(cl_object dim, cl_object data, cl_object stream);
extern ECL_API int ecl_readtable_get(cl_object rdtbl, int c, cl_object *macro);
extern ECL_API void ecl_readtable_set(cl_object rdtbl, int c, enum ecl_chattrib cat, cl_object macro_or_table);
extern ECL_API int ecl_readtable_get(cl_object rdtbl, int c, cl_object *macro, cl_object *table);
extern ECL_API void ecl_readtable_set(cl_object rdtbl, int c, enum ecl_chattrib cat, cl_object macro, cl_object table);
extern ECL_API cl_object ecl_read_constituent(cl_object in, bool not_first);
extern ECL_API cl_object ecl_read_delimited_list(int d, cl_object strm, bool proper);
extern ECL_API cl_object ecl_dispatch_reader_fun(cl_object in, cl_object dc);

3
src/h/object.h
View file

@ -727,7 +727,8 @@ enum ecl_chattrib { /* character attribute */
struct ecl_readtable_entry { /* read table entry */
enum ecl_chattrib syntax_type; /* character attribute */
cl_object dispatch; /* a macro, a hash or NIL */
cl_object macro; /* character macro */
cl_object table; /* dispatch table or NIL*/
};
enum ecl_readtable_case {