From 09e8d7dd0407562bde6808e3a36e2ac43bf03e40 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 6 Mar 2026 09:48:59 +0100 Subject: [PATCH] reader: merge back readtable.d into read.d and reader.d --- src/c/Makefile.in | 4 +- src/c/read.d | 321 ++++++++++++++++++++++++++++++++++------- src/c/reader.d | 107 ++++++++++++++ src/c/readtable.d | 354 ---------------------------------------------- src/h/internal.h | 2 +- 5 files changed, 378 insertions(+), 410 deletions(-) delete mode 100644 src/c/readtable.d diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 41039989e..cdbc4f0e9 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -70,8 +70,8 @@ WRITER_OBJS = print.o printer/float_to_digits.o printer/float_to_string.o printer/write_list.o printer/write_code.o printer/write_sse.o \ printer/print_unreadable.o -READER_OBJS = readtable.o reader.o read.o reader/rtab_cl.o \ - reader/parse_token.o reader/parse_integer.o reader/parse_number.o +READER_OBJS = reader.o read.o reader/rtab_cl.o \ + reader/parse_token.o reader/parse_integer.o reader/parse_number.o STREAM_OBJS = stream.o file.o streams/strm_os.o streams/strm_clos.o \ streams/strm_string.o streams/strm_composite.o streams/strm_common.o \ diff --git a/src/c/read.d b/src/c/read.d index 1c2175b84..3afb7dd2f 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -27,59 +27,6 @@ #define read_suppress (ecl_symbol_value(@'*read-suppress*') != ECL_NIL) -cl_object -si_get_buffer_string() -{ - const cl_env_ptr env = ecl_process_env(); - cl_object pool = env->string_pool; - cl_object output; - if (pool == ECL_NIL) { -#ifdef ECL_UNICODE - output = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); -#else - output = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); -#endif - } else { - output = CAR(pool); - env->string_pool = CDR(pool); - } - TOKEN_STRING_FILLP(output) = 0; - @(return output); -} - -cl_object -si_put_buffer_string(cl_object string) -{ - if (string != ECL_NIL) { - const cl_env_ptr env = ecl_process_env(); - cl_object pool = env->string_pool; - cl_index l = 0; - if (pool != ECL_NIL) { - /* We store the size of the pool in the string index */ - l = TOKEN_STRING_FILLP(ECL_CONS_CAR(pool)); - } - if (l < ECL_MAX_STRING_POOL_SIZE) { - /* Ok, by ignoring the following code, here we - * are doing like SBCL: we simply grow the - * input buffer and do not care about its - * size. */ -#if 0 - if (TOKEN_STRING_DIM(string) > 32*ECL_BUFFER_STRING_SIZE) { - /* String has been enlarged. Cut it. */ -#ifdef ECL_UNICODE - string = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); -#else - string = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); -#endif - } -#endif - TOKEN_STRING_FILLP(string) = l+1; - env->string_pool = CONS(string, pool); - } - } - @(return); -} - static cl_object patch_sharp(const cl_env_ptr env, cl_object x); cl_object @@ -674,6 +621,274 @@ si_read_token(cl_object strm) ecl_return1(the_env, object); } +/* -- readtable ----------------------------------------------------- */ + +static void ECL_INLINE +assert_type_readtable(cl_object function, cl_narg narg, cl_object p) +{ + unlikely_if (!ECL_READTABLEP(p)) { + FEwrong_type_nth_arg(function, narg, p, @[readtable]); + } +} + +static void +error_locked_readtable(cl_object r) +{ + cl_error(2, @"Cannot modify locked readtable ~A.", r); +} + +cl_object +cl_readtablep(cl_object readtable) +{ + @(return (ECL_READTABLEP(readtable) ? ECL_T : ECL_NIL)); +} + +cl_object +si_standard_readtable() +{ + @(return cl_core.standard_readtable); +} + +cl_object +ecl_current_readtable(void) +{ + const cl_env_ptr the_env = ecl_process_env(); + cl_object r; + + /* INV: *readtable* always has a value */ + r = ECL_SYM_VAL(the_env, @'*readtable*'); + unlikely_if (!ECL_READTABLEP(r)) { + ECL_SETQ(the_env, @'*readtable*', cl_core.standard_readtable); + FEerror("The value of *READTABLE*, ~S, was not a readtable.", 1, r); + } + return r; +} + +@(defun ext::readtable-lock (r &optional yesno) + cl_object output; + @ + assert_type_readtable(@[ext::readtable-lock], 1, r); + output = (r->readtable.locked)? ECL_T : ECL_NIL; + if (narg > 1) { + r->readtable.locked = !Null(yesno); + } + @(return output); + @) + +cl_object +cl_readtable_case(cl_object r) +{ + assert_type_readtable(@[readtable-case], 1, r); + switch (r->readtable.read_case) { + case ecl_case_upcase: r = @':upcase'; break; + case ecl_case_downcase: r = @':downcase'; break; + case ecl_case_invert: r = @':invert'; break; + case ecl_case_preserve: r = @':preserve'; + } + @(return r); +} + +cl_object +si_readtable_case_set(cl_object r, cl_object mode) +{ + assert_type_readtable(@[readtable-case], 1, r); + if (r->readtable.locked) { + error_locked_readtable(r); + } + if (mode == @':upcase') { + r->readtable.read_case = ecl_case_upcase; + } else if (mode == @':downcase') { + r->readtable.read_case = ecl_case_downcase; + } else if (mode == @':preserve') { + r->readtable.read_case = ecl_case_preserve; + } else if (mode == @':invert') { + r->readtable.read_case = ecl_case_invert; + } else { + const char *type = "(member :upcase :downcase :preserve :invert)"; + FEwrong_type_nth_arg(@[si::readtable-case-set], 2, + mode, ecl_read_from_cstring(type)); + } + @(return mode); +} + +cl_object +ecl_copy_readtable(cl_object from, cl_object to) +{ + struct ecl_readtable_entry *from_rtab, *to_rtab; + cl_index i; + size_t entry_bytes = sizeof(struct ecl_readtable_entry); + size_t total_bytes = entry_bytes * RTABSIZE; + cl_object output; + + assert_type_readtable(@[copy-readtable], 1, from); + /* For the sake of garbage collector and thread safety we + * create an incomplete object and only copy to the destination + * at the end in a more or less "atomic" (meaning "fast") way. + */ + output = ecl_alloc_object(t_readtable); + output->readtable.locked = 0; + output->readtable.table = to_rtab = (struct ecl_readtable_entry *) + ecl_alloc_align(total_bytes, entry_bytes); + from_rtab = from->readtable.table; + memcpy(to_rtab, from_rtab, total_bytes); + for (i = 0; i < RTABSIZE; i++) { + cl_object d = from_rtab[i].table; + if (ECL_HASH_TABLE_P(d)) { + d = si_copy_hash_table(d); + } + to_rtab[i].table = d; + } + output->readtable.read_case = from->readtable.read_case; +#ifdef ECL_UNICODE + if (!Null(from->readtable.hash)) { + output->readtable.hash = si_copy_hash_table(from->readtable.hash); + } else { + output->readtable.hash = ECL_NIL; + } +#endif + if (!Null(to)) { + assert_type_readtable(@[copy-readtable], 2, to); + to->readtable = output->readtable; + output = to; + } + return output; +} + +@(defun copy_readtable (&o (from ecl_current_readtable()) to) + @ + if (Null(from)) { + to = ecl_copy_readtable(cl_core.standard_readtable, to); + } else { + to = ecl_copy_readtable(from, to); + } + @(return to); + @) + +@(defun set_macro_character (c function &optional non_terminating_p + (readtable ecl_current_readtable())) + @ + if (readtable->readtable.locked) { + error_locked_readtable(readtable); + } + ecl_readtable_set(readtable, ecl_char_code(c), + Null(non_terminating_p)? + cat_terminating : + cat_non_terminating, + function, + ECL_NIL); + @(return ECL_T); + @) + +@(defun get_macro_character (c &optional (readtable ecl_current_readtable())) + enum ecl_chattrib cat; + cl_object macro; + @ + if (Null(readtable)) + readtable = cl_core.standard_readtable; + cat = ecl_readtable_get(readtable, ecl_char_code(c), ¯o, NULL); + @(return macro ((cat == cat_non_terminating)? ECL_T : ECL_NIL)); + @) + +@(defun set_syntax_from_char (tochr fromchr + &o (tordtbl ecl_current_readtable()) + fromrdtbl) + enum ecl_chattrib cat; + cl_object macro, table; + cl_fixnum fc, tc; + @ + if (tordtbl->readtable.locked) { + error_locked_readtable(tordtbl); + } + if (Null(fromrdtbl)) + fromrdtbl = cl_core.standard_readtable; + assert_type_readtable(@[readtable-case], 1, tordtbl); + assert_type_readtable(@[readtable-case], 2, fromrdtbl); + fc = ecl_char_code(fromchr); + tc = ecl_char_code(tochr); + + cat = ecl_readtable_get(fromrdtbl, fc, ¯o, &table); + if (ECL_HASH_TABLE_P(table)) { + table = si_copy_hash_table(table); + } + ecl_readtable_set(tordtbl, tc, cat, macro, table); + @(return ECL_T); + @) + +/* -- dispatch macro character -------------------------------------- */ +@(defun make_dispatch_macro_character + (chr &optional non_terminating_p (readtable ecl_current_readtable())) + enum ecl_chattrib cat; + cl_object table; + int c; + @ + if (readtable->readtable.locked) { + error_locked_readtable(readtable); + } + assert_type_readtable(@[make-dispatch-macro-character], 3, readtable); + c = ecl_char_code(chr); + cat = Null(non_terminating_p)? cat_terminating : cat_non_terminating; + 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, cl_core.dispatch_reader, table); + @(return ECL_T); + @) + +@(defun set_dispatch_macro_character (dspchr subchr fnc + &optional (readtable ecl_current_readtable())) + cl_object table; + cl_fixnum subcode; + @ + assert_type_readtable(@[set-dispatch-macro-character], 4, readtable); + ecl_readtable_get(readtable, ecl_char_code(dspchr), NULL, &table); + unlikely_if (readtable->readtable.locked) { + error_locked_readtable(readtable); + } + unlikely_if (!ECL_HASH_TABLE_P(table)) { + FEerror("~S is not a dispatch character.", 1, dspchr); + } + subcode = ecl_char_code(subchr); + if (Null(fnc)) { + ecl_remhash(ECL_CODE_CHAR(subcode), table); + } else { + _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); + } + if (ecl_lower_case_p(subcode)) { + subcode = ecl_char_upcase(subcode); + } else if (ecl_upper_case_p(subcode)) { + subcode = ecl_char_downcase(subcode); + } + if (Null(fnc)) { + ecl_remhash(ECL_CODE_CHAR(subcode), table); + } else { + _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); + } + @(return ECL_T); + @) + +@(defun get_dispatch_macro_character (dspchr subchr + &optional (readtable ecl_current_readtable())) + cl_object table; + cl_fixnum c; + @ + if (Null(readtable)) { + readtable = cl_core.standard_readtable; + } + assert_type_readtable(@[get-dispatch-macro-character], 3, readtable); + c = ecl_char_code(dspchr); + ecl_readtable_get(readtable, c, NULL, &table); + unlikely_if (!ECL_HASH_TABLE_P(table)) { + FEerror("~S is not a dispatch character.", 1, dspchr); + } + c = ecl_char_code(subchr); + + /* Since macro characters may take a number as argument, it is + not allowed to turn digits into dispatch macro characters */ + if (ecl_digitp(c, 10) >= 0) + @(return ECL_NIL); + @(return ecl_gethash_safe(subchr, table, ECL_NIL)); + @) + /* *---------------------------------------------------------------------- * diff --git a/src/c/reader.d b/src/c/reader.d index 09ec2afe0..8bf49e47b 100644 --- a/src/c/reader.d +++ b/src/c/reader.d @@ -26,6 +26,74 @@ #include #include +int +ecl_readtable_get(cl_object readtable, int c, cl_object *macro, cl_object *table) +{ + cl_object m, t; + enum ecl_chattrib cat; +#ifdef ECL_UNICODE + if (c >= RTABSIZE) { + cl_object hash = readtable->readtable.hash; + cat = cat_constituent; + m = ECL_NIL; + if (!Null(hash)) { + cl_object pair = ecl_gethash_safe(ECL_CODE_CHAR(c), hash, ECL_NIL); + if (!Null(pair)) { + cat = ecl_fixnum(ECL_CONS_CAR(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].macro; + t = readtable->readtable.table[c].table; + cat = readtable->readtable.table[c].syntax_type; + } + 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, cl_object table) +{ +#ifdef ECL_UNICODE + if (c >= RTABSIZE) { + cl_object hash = readtable->readtable.hash; + if (Null(hash)) { + hash = cl__make_hash_table(@'eql', ecl_make_fixnum(128), + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); + readtable->readtable.hash = hash; + } + _ecl_sethash(ECL_CODE_CHAR(c), hash, + CONS(ecl_make_fixnum(cat), + CONS(macro, + CONS(table, ECL_NIL)))); + } else +#endif + { + readtable->readtable.table[c].macro = macro; + readtable->readtable.table[c].table = table; + readtable->readtable.table[c].syntax_type = cat; + } +} + +/* FIXME unicode defines a range of "safe" characters, so that there are no + misleading pseudo-spaces in symbols and such. Investigate that. */ +bool +ecl_invalid_character_p(int c) +{ + return (c <= 32) || (c == 127); +} + +/* -- tokens ---------------------------------------------------------------- */ + static cl_object ecl_make_token() { @@ -52,6 +120,45 @@ si_token_escape(cl_object token) ecl_return1(the_env, object); } +cl_object +si_get_buffer_string() +{ + const cl_env_ptr env = ecl_process_env(); + cl_object pool = env->string_pool; + cl_object output; + if (pool == ECL_NIL) { +#ifdef ECL_UNICODE + output = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); +#else + output = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); +#endif + } else { + output = CAR(pool); + env->string_pool = CDR(pool); + } + TOKEN_STRING_FILLP(output) = 0; + @(return output); +} + +/* FIXME pools should be resizeable stacks. */ +cl_object +si_put_buffer_string(cl_object string) +{ + if (string != ECL_NIL) { + const cl_env_ptr env = ecl_process_env(); + cl_object pool = env->string_pool; + cl_index l = 0; + if (pool != ECL_NIL) { + /* We store the size of the pool in the string index */ + l = TOKEN_STRING_FILLP(ECL_CONS_CAR(pool)); + } + if (l < ECL_MAX_STRING_POOL_SIZE) { + TOKEN_STRING_FILLP(string) = l+1; + env->string_pool = CONS(string, pool); + } + } + @(return); +} /* FIXME pools should be resizeable stacks. */ cl_object diff --git a/src/c/readtable.d b/src/c/readtable.d deleted file mode 100644 index b6f3d3525..000000000 --- a/src/c/readtable.d +++ /dev/null @@ -1,354 +0,0 @@ -/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ - -/* - * readtable.d - readtable implementation - * - * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya - * Copyright (c) 1990 Giuseppe Attardi - * Copyright (c) 2001 Juan Jose Garcia Ripoll - * - * See file 'LICENSE' for the copyright details. - * - */ - -#define ECL_INCLUDE_MATH_H -#include -#include -#include /* for assert() */ -#include -#include -#include -#include -#include -#include -#include -#include - -static void ECL_INLINE -assert_type_readtable(cl_object function, cl_narg narg, cl_object p) -{ - unlikely_if (!ECL_READTABLEP(p)) { - FEwrong_type_nth_arg(function, narg, p, @[readtable]); - } -} - -cl_object -ecl_copy_readtable(cl_object from, cl_object to) -{ - struct ecl_readtable_entry *from_rtab, *to_rtab; - cl_index i; - size_t entry_bytes = sizeof(struct ecl_readtable_entry); - size_t total_bytes = entry_bytes * RTABSIZE; - cl_object output; - - assert_type_readtable(@[copy-readtable], 1, from); - /* For the sake of garbage collector and thread safety we - * create an incomplete object and only copy to the destination - * at the end in a more or less "atomic" (meaning "fast") way. - */ - output = ecl_alloc_object(t_readtable); - output->readtable.locked = 0; - output->readtable.table = to_rtab = (struct ecl_readtable_entry *) - ecl_alloc_align(total_bytes, entry_bytes); - from_rtab = from->readtable.table; - memcpy(to_rtab, from_rtab, total_bytes); - for (i = 0; i < RTABSIZE; i++) { - cl_object d = from_rtab[i].table; - if (ECL_HASH_TABLE_P(d)) { - d = si_copy_hash_table(d); - } - to_rtab[i].table = d; - } - output->readtable.read_case = from->readtable.read_case; -#ifdef ECL_UNICODE - if (!Null(from->readtable.hash)) { - output->readtable.hash = si_copy_hash_table(from->readtable.hash); - } else { - output->readtable.hash = ECL_NIL; - } -#endif - if (!Null(to)) { - assert_type_readtable(@[copy-readtable], 2, to); - to->readtable = output->readtable; - output = to; - } - return output; -} - -cl_object -ecl_current_readtable(void) -{ - const cl_env_ptr the_env = ecl_process_env(); - cl_object r; - - /* INV: *readtable* always has a value */ - r = ECL_SYM_VAL(the_env, @'*readtable*'); - unlikely_if (!ECL_READTABLEP(r)) { - ECL_SETQ(the_env, @'*readtable*', cl_core.standard_readtable); - FEerror("The value of *READTABLE*, ~S, was not a readtable.", 1, r); - } - return r; -} - -@(defun copy_readtable (&o (from ecl_current_readtable()) to) - @ - if (Null(from)) { - to = ecl_copy_readtable(cl_core.standard_readtable, to); - } else { - to = ecl_copy_readtable(from, to); - } - @(return to); - @) - -cl_object -cl_readtable_case(cl_object r) -{ - assert_type_readtable(@[readtable-case], 1, r); - switch (r->readtable.read_case) { - case ecl_case_upcase: r = @':upcase'; break; - case ecl_case_downcase: r = @':downcase'; break; - case ecl_case_invert: r = @':invert'; break; - case ecl_case_preserve: r = @':preserve'; - } - @(return r); -} - -static void -error_locked_readtable(cl_object r) -{ - cl_error(2, @"Cannot modify locked readtable ~A.", r); -} - -cl_object -si_readtable_case_set(cl_object r, cl_object mode) -{ - assert_type_readtable(@[readtable-case], 1, r); - if (r->readtable.locked) { - error_locked_readtable(r); - } - if (mode == @':upcase') { - r->readtable.read_case = ecl_case_upcase; - } else if (mode == @':downcase') { - r->readtable.read_case = ecl_case_downcase; - } else if (mode == @':preserve') { - r->readtable.read_case = ecl_case_preserve; - } else if (mode == @':invert') { - r->readtable.read_case = ecl_case_invert; - } else { - const char *type = "(member :upcase :downcase :preserve :invert)"; - FEwrong_type_nth_arg(@[si::readtable-case-set], 2, - mode, ecl_read_from_cstring(type)); - } - @(return mode); -} - -cl_object -cl_readtablep(cl_object readtable) -{ - @(return (ECL_READTABLEP(readtable) ? ECL_T : ECL_NIL)); -} - -int -ecl_readtable_get(cl_object readtable, int c, cl_object *macro, cl_object *table) -{ - cl_object m, t; - enum ecl_chattrib cat; -#ifdef ECL_UNICODE - if (c >= RTABSIZE) { - cl_object hash = readtable->readtable.hash; - cat = cat_constituent; - m = ECL_NIL; - if (!Null(hash)) { - cl_object pair = ecl_gethash_safe(ECL_CODE_CHAR(c), hash, ECL_NIL); - if (!Null(pair)) { - cat = ecl_fixnum(ECL_CONS_CAR(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].macro; - t = readtable->readtable.table[c].table; - cat = readtable->readtable.table[c].syntax_type; - } - 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, cl_object table) -{ - if (readtable->readtable.locked) { - error_locked_readtable(readtable); - } -#ifdef ECL_UNICODE - if (c >= RTABSIZE) { - cl_object hash = readtable->readtable.hash; - if (Null(hash)) { - hash = cl__make_hash_table(@'eql', ecl_make_fixnum(128), - ecl_ct_default_rehash_size, - ecl_ct_default_rehash_threshold); - readtable->readtable.hash = hash; - } - _ecl_sethash(ECL_CODE_CHAR(c), hash, - CONS(ecl_make_fixnum(cat), - CONS(macro, - CONS(table, ECL_NIL)))); - } else -#endif - { - readtable->readtable.table[c].macro = macro; - readtable->readtable.table[c].table = table; - readtable->readtable.table[c].syntax_type = cat; - } -} - -/* FIXME unicode defines a range of "safe" characters, so that there are no - misleading pseudo-spaces in symbols and such. Investigate that. */ -bool -ecl_invalid_character_p(int c) -{ - return (c <= 32) || (c == 127); -} - -@(defun set_syntax_from_char (tochr fromchr - &o (tordtbl ecl_current_readtable()) - fromrdtbl) - enum ecl_chattrib cat; - cl_object macro, table; - cl_fixnum fc, tc; - @ - if (tordtbl->readtable.locked) { - error_locked_readtable(tordtbl); - } - if (Null(fromrdtbl)) - fromrdtbl = cl_core.standard_readtable; - assert_type_readtable(@[readtable-case], 1, tordtbl); - assert_type_readtable(@[readtable-case], 2, fromrdtbl); - fc = ecl_char_code(fromchr); - tc = ecl_char_code(tochr); - - cat = ecl_readtable_get(fromrdtbl, fc, ¯o, &table); - if (ECL_HASH_TABLE_P(table)) { - table = si_copy_hash_table(table); - } - ecl_readtable_set(tordtbl, tc, cat, macro, table); - @(return ECL_T); - @) - -@(defun set_macro_character (c function &optional non_terminating_p - (readtable ecl_current_readtable())) - @ - ecl_readtable_set(readtable, ecl_char_code(c), - Null(non_terminating_p)? - cat_terminating : - cat_non_terminating, - function, - ECL_NIL); - @(return ECL_T); - @) - -@(defun get_macro_character (c &optional (readtable ecl_current_readtable())) - enum ecl_chattrib cat; - cl_object macro; - @ - if (Null(readtable)) - readtable = cl_core.standard_readtable; - cat = ecl_readtable_get(readtable, ecl_char_code(c), ¯o, NULL); - @(return macro ((cat == cat_non_terminating)? ECL_T : ECL_NIL)); - @) - -@(defun make_dispatch_macro_character (chr - &optional non_terminating_p (readtable ecl_current_readtable())) - enum ecl_chattrib cat; - cl_object table; - int c; - @ - assert_type_readtable(@[make-dispatch-macro-character], 3, readtable); - c = ecl_char_code(chr); - cat = Null(non_terminating_p)? cat_terminating : cat_non_terminating; - 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, cl_core.dispatch_reader, table); - @(return ECL_T); - @) - -@(defun set_dispatch_macro_character (dspchr subchr fnc - &optional (readtable ecl_current_readtable())) - cl_object table; - cl_fixnum subcode; - @ - assert_type_readtable(@[set-dispatch-macro-character], 4, readtable); - ecl_readtable_get(readtable, ecl_char_code(dspchr), NULL, &table); - unlikely_if (readtable->readtable.locked) { - error_locked_readtable(readtable); - } - unlikely_if (!ECL_HASH_TABLE_P(table)) { - FEerror("~S is not a dispatch character.", 1, dspchr); - } - subcode = ecl_char_code(subchr); - if (Null(fnc)) { - ecl_remhash(ECL_CODE_CHAR(subcode), table); - } else { - _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); - } - if (ecl_lower_case_p(subcode)) { - subcode = ecl_char_upcase(subcode); - } else if (ecl_upper_case_p(subcode)) { - subcode = ecl_char_downcase(subcode); - } - if (Null(fnc)) { - ecl_remhash(ECL_CODE_CHAR(subcode), table); - } else { - _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); - } - @(return ECL_T); - @) - -@(defun get_dispatch_macro_character (dspchr subchr - &optional (readtable ecl_current_readtable())) - cl_object table; - cl_fixnum c; - @ - if (Null(readtable)) { - readtable = cl_core.standard_readtable; - } - assert_type_readtable(@[get-dispatch-macro-character], 3, readtable); - c = ecl_char_code(dspchr); - ecl_readtable_get(readtable, c, NULL, &table); - unlikely_if (!ECL_HASH_TABLE_P(table)) { - FEerror("~S is not a dispatch character.", 1, dspchr); - } - c = ecl_char_code(subchr); - - /* Since macro characters may take a number as argument, it is - not allowed to turn digits into dispatch macro characters */ - if (ecl_digitp(c, 10) >= 0) - @(return ECL_NIL); - @(return ecl_gethash_safe(subchr, table, ECL_NIL)); - @) - -cl_object -si_standard_readtable() -{ - @(return cl_core.standard_readtable); -} - -@(defun ext::readtable-lock (r &optional yesno) - cl_object output; - @ - assert_type_readtable(@[ext::readtable-lock], 1, r); - output = (r->readtable.locked)? ECL_T : ECL_NIL; - if (narg > 1) { - r->readtable.locked = !Null(yesno); - } - @(return output); - @) diff --git a/src/h/internal.h b/src/h/internal.h index 0c51ea280..d1eee99a6 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -679,7 +679,7 @@ extern cl_object mp_get_rwlock_write_wait(cl_object lock); cl_fixnum limit, __ecl_high; \ for(__ecl_idx = 0; __ecl_idx <= __ecl_ndx; __ecl_idx+=2) { \ if (__ecl_idx == __ecl_ndx) { \ - limit = __ecl_high = ecl_length(string); \ + limit = __ecl_high = TOKEN_STRING_FILLP(string); \ } else { \ limit = ecl_fixnum(__ecl_v[__ecl_idx]); \ __ecl_high = ecl_fixnum(__ecl_v[__ecl_idx+1]); \