From cc33abf37a43aa325440cc0c55ded5b204bd4438 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 28 Feb 2026 22:38:03 +0100 Subject: [PATCH] reader: move common-lisp specific readtable entries t rtab_cl.d --- src/c/Makefile.in | 2 +- src/c/read.d | 1030 ++-------------------------------------- src/c/reader/rtab_cl.d | 1010 +++++++++++++++++++++++++++++++++++++++ src/h/external.h | 5 + 4 files changed, 1048 insertions(+), 999 deletions(-) create mode 100644 src/c/reader/rtab_cl.d diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 91a8da1a6..890f28292 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -70,7 +70,7 @@ 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 = read.o reader/parse_integer.o reader/parse_number.o +READER_OBJS = read.o reader/rtab_cl.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 3920e57bc..06d43c849 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -102,9 +102,26 @@ si_put_buffer_string(cl_object string) @(return); } -static void extra_argument (int c, cl_object stream, cl_object d); static cl_object patch_sharp(const cl_env_ptr env, cl_object x); -static cl_object do_read_delimited_list(int d, cl_object strm, bool proper_list); + +cl_object +ecl_read_eval(cl_object in) +{ + const cl_env_ptr the_env = ecl_process_env(); + cl_object c = ecl_read_object(in); + unlikely_if (c == OBJNULL) + FEend_of_file(in); + if (read_suppress) { + @(return ECL_NIL); + } + unlikely_if (ecl_cmp_symbol_value(the_env, @'*read-eval*') == ECL_NIL) + FEreader_error("Cannot evaluate the form #.~A", in, 1, c); + /* FIXME! We should do something here to ensure that the #. + * only uses the #n# that have been defined */ + c = patch_sharp(the_env, c); + c = si_eval_with_env(1, c); + return c; +} cl_object ecl_read_object_non_recursive(cl_object in) @@ -158,7 +175,7 @@ invert_buffer_case(cl_object x, cl_object escape_list, int sign) } while (i >= 0); } -static cl_object +cl_object ecl_read_object_with_delimiter(cl_object in, int delimiter, int flags, enum ecl_chattrib a) { @@ -433,78 +450,16 @@ si_read_object_or_ignore(cl_object in, cl_object eof) return x; } -static cl_object -right_parenthesis_reader(cl_object in, cl_object character) -{ - FEreader_error("Unmatched right parenthesis, #\\)", in, 0); -} - -static cl_object -left_parenthesis_reader(cl_object in, cl_object character) -{ - const char c = ')'; - @(return do_read_delimited_list(c, in, 0)); -} - /* - * BACKQUOTE READER - */ - -static -cl_object comma_reader(cl_object in, cl_object c) -{ - cl_object x, y; - const cl_env_ptr env = ecl_process_env(); - cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(env, @'si::*backq-level*')); - - unlikely_if (backq_level <= 0 && !read_suppress) - FEreader_error("A comma has appeared out of a backquote.", in, 0); - /* Read character & complain at EOF */ - c = cl_peek_char(2,ECL_NIL,in); - if (c == ECL_CODE_CHAR('@@')) { - x = @'si::unquote-splice'; - ecl_read_char(in); - } else if (c == ECL_CODE_CHAR('.')) { - x = @'si::unquote-nsplice'; - ecl_read_char(in); - } else { - x = @'si::unquote'; - } - ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level-1)); - y = ecl_read_object(in); - ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); - return cl_list(2, x, y); -} - -static -cl_object backquote_reader(cl_object in, cl_object c) -{ - const cl_env_ptr the_env = ecl_process_env(); - cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(the_env, @'si::*backq-level*')); - ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level+1)); - c = ecl_read_object(in); - ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); - unlikely_if (c == OBJNULL) - FEend_of_file(in); - unlikely_if (read_suppress) - @(return ECL_NIL); -#if 0 - @(return cl_macroexpand_1(2, cl_list(2, @'si::quasiquote', in), ECL_NIL));; -#else - @(return cl_list(2,@'si::quasiquote',c)); -#endif -} - -/* - read_constituent(in, 0) reads a sequence of constituent characters from stream - in and places it in token. As a help, it returns TRUE or FALSE depending on - the value of *READ-SUPPRESS*. + ecl_read_constituent(in, 0) reads a sequence of constituent characters from + stream in and places it in token. As a help, it returns TRUE or FALSE + depending on the value of *READ-SUPPRESS*. The flag not_first is used by some reader macros to signify, that it is not a - standalone token. For example #x123 calls read_constituent(in, 1) for "123". + standalone token. For example #x123 calls ecl_read_constituent(in, 1) for "123". */ -static cl_object -read_constituent(cl_object in, bool not_first) +cl_object +ecl_read_constituent(cl_object in, bool not_first) { int store = !read_suppress; cl_object rtbl = ecl_current_readtable(); @@ -531,36 +486,8 @@ read_constituent(cl_object in, bool not_first) return (read_suppress)? ECL_NIL : token; } -static void -read_string_into_buffer(cl_object in, cl_object c, cl_object buffer) -{ - int delim = ECL_CHAR_CODE(c); - cl_object rtbl = ecl_current_readtable(); - for (;;) { - int c = ecl_read_char_noeof(in); - if (c == delim) - break; - else if (ecl_readtable_get(rtbl, c, NULL) == cat_single_escape) - c = ecl_read_char_noeof(in); - ecl_string_push_extend(buffer, c); - } -} - -static cl_object -double_quote_reader(cl_object in, cl_object c) -{ - cl_object output; - cl_object token = si_get_buffer_string(); - read_string_into_buffer(in, c, token); - /* Must be kept a SIMPLE-STRING, meaning a (SIMPLE-ARRAY CHARACTERS - * (*)), see CLHS 2.4.5. We thus can't coerce to a BASE-STRING. */ - output = cl_copy_seq(token); - si_put_buffer_string(token); - @(return output); -} - -static cl_object -dispatch_reader_fun(cl_object in, cl_object dc) +cl_object +ecl_dispatch_reader_fun(cl_object in, cl_object dc) { cl_object readtable = ecl_current_readtable(); cl_object dispatch_table; @@ -609,577 +536,6 @@ dispatch_macro_character(cl_object table, cl_object in, int c, bool signal_error } } -static cl_object -single_quote_reader(cl_object in, cl_object c) -{ - c = ecl_read_object(in); - unlikely_if (c == OBJNULL) - FEend_of_file(in); - @(return cl_list(2, @'quote', c)); -} - -static cl_object -void_reader3(cl_object in, cl_object c, cl_object f) -{ - /* no result */ - @(return); -} - -static cl_object -semicolon_reader(cl_object in, cl_object c) -{ - int auxc; - - do - auxc = ecl_read_char(in); - while (auxc != '\n' && auxc != EOF); - /* no result */ - @(return); -} - -/* - sharpmacro routines -*/ - -static cl_object -sharp_generic_error(cl_object in, cl_object c, cl_object n) -{ - FEreader_error("The character ~:C is not a valid dispatch macro character", - in, 1, c); -} - -static cl_object -sharp_C_reader(cl_object in, cl_object c, cl_object d) -{ - const cl_env_ptr the_env = ecl_process_env(); - cl_object x, real, imag; - - if (d != ECL_NIL && !read_suppress) - extra_argument('C', in, d); - x = ecl_read_object(in); - unlikely_if (x == OBJNULL) - FEend_of_file(in); - if (read_suppress) - @(return ECL_NIL); - unlikely_if (!ECL_CONSP(x) || ecl_length(x) != 2) - FEreader_error("Reader macro #C should be followed by a list", - in, 0); - real = CAR(x); - imag = CADR(x); - /* INV: ecl_make_complex() checks its types. When reading circular - structures, we cannot check the types of the elements, and we - must build the complex number by hand. */ - if ((CONSP(real) || CONSP(imag)) && - !Null(ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'))) - { - x = ecl_alloc_object(t_complex); - x->gencomplex.real = real; - x->gencomplex.imag = imag; - } else { - x = ecl_make_complex(real, imag); - } - @(return x); -} - -static cl_object -sharp_backslash_reader(cl_object in, cl_object c, cl_object d) -{ - const cl_env_ptr the_env = ecl_process_env(); - cl_object token; - if (d != ECL_NIL && !read_suppress) { - unlikely_if (!ECL_FIXNUMP(d) || d != ecl_make_fixnum(0)) { - FEreader_error("~S is an illegal CHAR-FONT.", in, 1, d); - } - } - token = ecl_read_object_with_delimiter(in, EOF, ECL_READ_ONLY_TOKEN, - cat_single_escape); - if (token == ECL_NIL) { - c = ECL_NIL; - } else if (TOKEN_STRING_FILLP(token) == 1) { - c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,0)); - } else if (TOKEN_STRING_FILLP(token) == 2 && TOKEN_STRING_CHAR_CMP(token,0,'^')) { - /* #\^x */ - c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,1) & 037); - } else { - cl_object nc = cl_name_char(token); - unlikely_if (Null(nc)) { - FEreader_error("~S is an illegal character name.", in, 1, token); - } - c = nc; - } - si_put_buffer_string(token); - ecl_return1(the_env, c); -} - -static cl_object -sharp_single_quote_reader(cl_object in, cl_object c, cl_object d) -{ - bool suppress = read_suppress; - if(d != ECL_NIL && !suppress) - extra_argument('\'', in, d); - c = ecl_read_object(in); - unlikely_if (c == OBJNULL) { - FEend_of_file(in); - } else if (suppress) { - c = ECL_NIL; - } else { - c = cl_list(2, @'function', c); - } - @(return c); -} - -static cl_object -sharp_Y_reader(cl_object in, cl_object c, cl_object d) -{ - cl_index i; - cl_object x, rv, nth, lex; - - if (d != ECL_NIL && !read_suppress) - extra_argument('Y', in, d); - x = ecl_read_object(in); - unlikely_if (x == OBJNULL) { - FEend_of_file(in); - } - if (read_suppress) { - @(return ECL_NIL); - } - - unlikely_if (!ECL_CONSP(x) || ecl_length(x) < 5) { - FEreader_error("Reader macro #Y should be followed by a list", in, 0); - } - - rv = ecl_alloc_object(t_bytecodes); - - rv->bytecodes.name = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - - lex = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - - rv->bytecodes.definition = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - - nth = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - rv->bytecodes.code_size = ecl_to_fix(cl_list_length(nth)); - rv->bytecodes.code = ecl_alloc_atomic(rv->bytecodes.code_size * sizeof(uint16_t)); - for ( i=0; !ecl_endp(nth) ; i++, nth=ECL_CONS_CDR(nth) ) - ((cl_opcode*)(rv->bytecodes.code))[i] = ecl_to_fix(ECL_CONS_CAR(nth)); - - nth = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - rv->bytecodes.data = nth; - - nth = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - rv->bytecodes.flex = nth; - - nth = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - rv->bytecodes.nlcl = nth; - - if (ECL_ATOM(x)) { - nth = ECL_NIL; - } else { - nth = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - } - rv->bytecodes.file = nth; - if (ECL_ATOM(x)) { - nth = ecl_make_fixnum(0); - } else { - nth = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - } - rv->bytecodes.file_position = nth; - - rv->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; - - if (lex != ECL_NIL) { - cl_object x = ecl_alloc_object(t_bclosure); - x->bclosure.code = rv; - x->bclosure.lex = lex; - x->bclosure.entry = _ecl_bclosure_dispatch_vararg; - rv = x; - } - @(return rv); -} - -static cl_object -sharp_double_quote_reader(cl_object in, cl_object c, cl_object d) -{ - /* Base string reader. Used for data in compiled files. */ - cl_object s, token; - - if (d != ECL_NIL && !read_suppress) - extra_argument('"', in, d); - - token = si_get_buffer_string(); - read_string_into_buffer(in, c, token); - s = si_copy_to_simple_base_string(token); - si_put_buffer_string(token); - - if (read_suppress) - @(return ECL_NIL); - @(return s); -} - -#define QUOTE 1 -#define EVAL 2 -#define LIST 3 -#define LISTX 4 -#define APPEND 5 -#define NCONC 6 - - -/* - *---------------------------------------------------------------------- - * Stack of unknown size - *---------------------------------------------------------------------- - */ - -cl_object -si_make_backq_vector(cl_object d, cl_object data, cl_object in) -{ - const cl_env_ptr the_env = ecl_process_env(); - cl_object v, last; - cl_index dim, i; - if (Null(d)) { - dim = ecl_length(data); - } else { - dim = ecl_fixnum(d); - } - v = ecl_alloc_simple_vector(dim, ecl_aet_object); - for (i = 0, last = ECL_NIL; i < dim; i++) { - if (data == ECL_NIL) { - /* ... we fill the vector with the last element read (or NIL). */ - for (; i < dim; i++) { - ecl_aset_unsafe(v, i, last); - } - break; - } - ecl_aset_unsafe(v, i, last = ecl_car(data)); - data = ECL_CONS_CDR(data); - } - unlikely_if (data != ECL_NIL) { - if (in != ECL_NIL) { - FEreader_error("Vector larger than specified length," - "~D.", in, 1, d); - } else { - FEerror("Vector larger than specified length, ~D", 1, d); - } - } - ecl_return1(the_env, v); -} - -static cl_object -sharp_left_parenthesis_reader(cl_object in, cl_object c, cl_object d) -{ - extern int _cl_backq_car(cl_object *); - const cl_env_ptr the_env = ecl_process_env(); - cl_object v; - unlikely_if (!Null(d) && - (!ECL_FIXNUMP(d) || ecl_fixnum_minusp(d) || - ecl_fixnum_greater(d, ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT)))) - { - FEreader_error("Invalid dimension size ~D in #()", in, 1, d); - } - if (ecl_fixnum_plusp(ECL_SYM_VAL(the_env, @'si::*backq-level*'))) { - /* First case: ther might be unquoted elements in the vector. - * Then we just create a form that generates the vector. - */ - cl_object x = do_read_delimited_list(')', in, 1); - cl_index a = _cl_backq_car(&x); - if (a != QUOTE) { - v = cl_list(2, @'si::unquote', - cl_list(4, @'si::make-backq-vector', d, x, ECL_NIL)); - } else { - return si_make_backq_vector(d, x, in); - } - } else if (read_suppress) { - /* Second case: *read-suppress* = t, we ignore the data */ - do_read_delimited_list(')', in, 1); - v = ECL_NIL; - } else if (Null(d)) { - /* Third case: no dimension provided. Read a list and - coerce it to vector. */ - return si_make_backq_vector(d, do_read_delimited_list(')', in, 1), in); - } else { - /* Finally: Both dimension and data are provided. The - amount of data cannot exceed the length, but it may - be smaller, and in that case...*/ - cl_object last; - cl_index dim = ecl_fixnum(d), i; - v = ecl_alloc_simple_vector(dim, ecl_aet_object); - for (i = 0, last = ECL_NIL;; i++) { - cl_object aux = ecl_read_object_with_delimiter(in, ')', 0, - cat_constituent); - if (aux == OBJNULL) - break; - unlikely_if (i >= dim) { - FEreader_error("Vector larger than specified length," - "~D.", in, 1, d); - } - ecl_aset_unsafe(v, i, last = aux); - } - /* ... we fill the vector with the last element read (or NIL). */ - for (; i < dim; i++) { - ecl_aset_unsafe(v, i, last); - } - } - @(return v); -} - -static cl_object -sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) -{ - cl_env_ptr env = ecl_process_env(); - cl_index sp = ECL_STACK_INDEX(env); - cl_object last, elt, x; - cl_fixnum dim, dimcount, i; - cl_object rtbl = ecl_current_readtable(); - enum ecl_chattrib a; - - if (read_suppress) { - read_constituent(in, 1); - @(return ECL_NIL); - } - for (dimcount = 0 ;; dimcount++) { - int x = ecl_read_char(in); - if (x == EOF) - break; - a = ecl_readtable_get(rtbl, x, NULL); - if (a == cat_terminating || a == cat_whitespace) { - ecl_unread_char(x, in); - break; - } - unlikely_if (a == cat_single_escape || a == cat_multiple_escape || - (x != '0' && x != '1')) - { - FEreader_error("Character ~:C is not allowed after #*", - in, 1, ECL_CODE_CHAR(x)); - } - ECL_STACK_PUSH(env, ecl_make_fixnum(x == '1')); - } - if (Null(d)) { - dim = dimcount; - } else { - unlikely_if (!ECL_FIXNUMP(d) || ((dim = ecl_fixnum(d)) < 0) || - (dim > ECL_ARRAY_DIMENSION_LIMIT)) - { - FEreader_error("Wrong vector dimension size ~D in #*.", - in, 1, d); - } - unlikely_if (dimcount > dim) - FEreader_error("Too many elements in #*.", in, 0); - unlikely_if (dim && (dimcount == 0)) - FEreader_error("Cannot fill the bit-vector #*.", in, 0); - } - last = ECL_STACK_REF(env,-1); - x = ecl_alloc_simple_vector(dim, ecl_aet_bit); - for (i = 0; i < dim; i++) { - elt = (i < dimcount) ? env->run_stack.org[sp+i] : last; - if (elt == ecl_make_fixnum(0)) - x->vector.self.bit[i/CHAR_BIT] &= ~(0200 >> i%CHAR_BIT); - else - x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT; - } - ECL_STACK_POP_N_UNSAFE(env, dimcount); - @(return x); -} - -static cl_object -sharp_colon_reader(cl_object in, cl_object ch, cl_object d) -{ - cl_object rtbl = ecl_current_readtable(); - enum ecl_chattrib a; - int c; - cl_object output, token; - - if (d != ECL_NIL && !read_suppress) - extra_argument(':', in, d); - c = ecl_read_char_noeof(in); - a = ecl_readtable_get(rtbl, c, NULL); - token = si_get_buffer_string(); - goto L; - for (;;) { - ecl_string_push_extend(token, c); - K: - c = ecl_read_char(in); - if (c == EOF) - goto M; - a = ecl_readtable_get(rtbl, c, NULL); - L: - if (a == cat_single_escape) { - c = ecl_read_char_noeof(in); - a = cat_constituent; - } else if (a == cat_multiple_escape) { - for (;;) { - c = ecl_read_char_noeof(in); - a = ecl_readtable_get(rtbl, c, NULL); - if (a == cat_single_escape) { - c = ecl_read_char_noeof(in); - a = cat_constituent; - } else if (a == cat_multiple_escape) - break; - ecl_string_push_extend(token, c); - } - goto K; - } else if (ecl_lower_case_p(c)) { - c = ecl_char_upcase(c); - } else if (c == ':' && !read_suppress) { - FEreader_error("An uninterned symbol must not contain a package prefix", in, 0); - } - if (a == cat_whitespace || a == cat_terminating) - break; - } - ecl_unread_char(c, in); - - M: - if (read_suppress) { - output = ECL_NIL; - } else { - output = cl_make_symbol(token); - } - si_put_buffer_string(token); - @(return output); -} - -static cl_object -sharp_dot_reader(cl_object in, cl_object c, cl_object d) -{ - const cl_env_ptr env = ecl_process_env(); - if (d != ECL_NIL && !read_suppress) - extra_argument('.', in, d); - c = ecl_read_object(in); - unlikely_if (c == OBJNULL) - FEend_of_file(in); - if (read_suppress) { - @(return ECL_NIL); - } - unlikely_if (ecl_cmp_symbol_value(env, @'*read-eval*') == ECL_NIL) - FEreader_error("Cannot evaluate the form #.~A", in, 1, c); - /* FIXME! We should do something here to ensure that the #. - * only uses the #n# that have been defined */ - c = patch_sharp(env, c); - c = si_eval_with_env(1, c); - @(return c); -} - -static cl_object -read_number(cl_object in, int radix, cl_object macro_char) -{ - cl_index i; - cl_object x; - /* read_constituent is called with not_first=true, because we are called by - reader macros for composite tokens, like #x123. -- jd 2024-05-12 */ - cl_object token = read_constituent(in, 1); - if (token == ECL_NIL) { - x = ECL_NIL; - } else { - x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, radix); - unlikely_if (x == OBJNULL || x == ECL_NIL || - i != TOKEN_STRING_FILLP(token)) - { - FEreader_error("Cannot parse the #~A readmacro.", in, 1, - macro_char); - } - unlikely_if (cl_rationalp(x) == ECL_NIL) { - FEreader_error("The float ~S appeared after the #~A readmacro.", - in, 2, x, macro_char); - } - si_put_buffer_string(token); - } - return x; -} - -static cl_object -sharp_B_reader(cl_object in, cl_object c, cl_object d) -{ - if(d != ECL_NIL && !read_suppress) - extra_argument('B', in, d); - @(return (read_number(in, 2, ECL_CODE_CHAR('B')))); -} - -static cl_object -sharp_O_reader(cl_object in, cl_object c, cl_object d) -{ - if(d != ECL_NIL && !read_suppress) - extra_argument('O', in, d); - @(return (read_number(in, 8, ECL_CODE_CHAR('O')))); -} - -static cl_object -sharp_X_reader(cl_object in, cl_object c, cl_object d) -{ - if(d != ECL_NIL && !read_suppress) - extra_argument('X', in, d); - @(return (read_number(in, 16, ECL_CODE_CHAR('X')))); -} - -static cl_object -sharp_R_reader(cl_object in, cl_object c, cl_object d) -{ - int radix; - if (read_suppress) { - radix = 10; - } else unlikely_if (!ECL_FIXNUMP(d)) { - FEreader_error("No radix was supplied in the #R readmacro.", in, 0); - } else { - radix = ecl_fixnum(d); - unlikely_if (radix > 36 || radix < 2) { - FEreader_error("~S is an illegal radix.", in, 1, d); - } - } - @(return (read_number(in, radix, ECL_CODE_CHAR('R')))); -} - -static cl_object -sharp_eq_reader(cl_object in, cl_object c, cl_object d) -{ - const cl_env_ptr the_env = ecl_process_env(); - cl_object pair, value; - cl_object sharp_eq_context = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); - - if (read_suppress) { - @(return); - } - unlikely_if (Null(d)) { - FEreader_error("The #= readmacro requires an argument.", in, 0); - } - unlikely_if (ecl_assq(d, sharp_eq_context) != ECL_NIL) { - FEreader_error("Duplicate definitions for #~D=.", in, 1, d); - } - pair = CONS(d, OBJNULL); - ECL_SETQ(the_env, @'si::*sharp-eq-context*', CONS(pair, sharp_eq_context)); - value = ecl_read_object(in); - unlikely_if (value == pair) { - FEreader_error("#~D# is defined by itself.", in, 1, d); - } - ECL_RPLACD(pair, value); - ecl_return1(the_env, value); -} - -static cl_object -sharp_sharp_reader(cl_object in, cl_object c, cl_object d) -{ - const cl_env_ptr the_env = ecl_process_env(); - cl_object pair; - - if (read_suppress) - ecl_return1(the_env, ECL_NIL); - unlikely_if (Null(d)) { - FEreader_error("The ## readmacro requires an argument.", in, 0); - } - pair = ecl_assq(d, ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*')); - unlikely_if (pair == ECL_NIL) { - FEreader_error("#~D# is undefined.", in, 1, d); - } else { - cl_object value = ECL_CONS_CDR(pair); - ecl_return1(the_env, (value == OBJNULL)? pair : value); - } -} - static cl_object do_patch_sharp(cl_object x, cl_object table) { @@ -1312,73 +668,6 @@ patch_sharp(const cl_env_ptr the_env, cl_object x) } } -#define sharp_plus_reader void_reader3 -#define sharp_minus_reader void_reader3 - -static cl_object -sharp_vertical_bar_reader(cl_object in, cl_object ch, cl_object d) -{ - int c; - int level = 0; - - if (d != ECL_NIL && !read_suppress) - extra_argument('|', in, d); - for (;;) { - c = ecl_read_char_noeof(in); - L: - if (c == '#') { - c = ecl_read_char_noeof(in); - if (c == '|') - level++; - } else if (c == '|') { - c = ecl_read_char_noeof(in); - if (c == '#') { - if (level == 0) - break; - else - --level; - } else - goto L; - } - } - /* no result */ - @(return); -} - -/* - #P" ... " returns the pathname with namestring ... . -*/ -static cl_object -sharp_P_reader(cl_object in, cl_object c, cl_object d) -{ - bool suppress = read_suppress; - if (d != ECL_NIL && !suppress) - extra_argument('P', in, d); - d = ecl_read_object(in); - if (suppress) { - d = ECL_NIL; - } else { - d = cl_parse_namestring(3, d, ECL_NIL, ECL_NIL); - } - @(return d); -} - -/* - #$ fixnum returns a random-state with the fixnum - as its content. -*/ -static cl_object -sharp_dollar_reader(cl_object in, cl_object c, cl_object d) -{ - cl_object rs; - if (d != ECL_NIL && !read_suppress) - extra_argument('$', in, d); - c = ecl_read_object(in); - rs = ecl_make_random_state(c); - - @(return rs); -} - /* readtable routines */ @@ -1546,8 +835,8 @@ stream_or_default_input(cl_object stream) @(return x); @) -static cl_object -do_read_delimited_list(int d, cl_object in, bool proper_list) +cl_object +ecl_read_delimited_list(int d, cl_object in, bool proper_list) { int after_dot = 0; bool suppress = read_suppress; @@ -1596,11 +885,11 @@ do_read_delimited_list(int d, cl_object in, bool proper_list) delimiter = ecl_char_code(d); strm = stream_or_default_input(strm); if (!Null(recursivep)) { - l = do_read_delimited_list(delimiter, strm, 1); + l = ecl_read_delimited_list(delimiter, strm, 1); } else { ecl_bds_bind(the_env, @'si::*sharp-eq-context*', ECL_NIL); ecl_bds_bind(the_env, @'si::*backq-level*', ecl_make_fixnum(0)); - l = do_read_delimited_list(delimiter, strm, 1); + l = ecl_read_delimited_list(delimiter, strm, 1); l = patch_sharp(the_env, l); ecl_bds_unwind_n(the_env, 2); } @@ -2039,261 +1328,6 @@ si_standard_readtable() @(return output); @) -static void -extra_argument(int c, cl_object stream, cl_object d) -{ - FEreader_error("~S is an extra argument for the #~C readmacro.", - stream, 2, d, ECL_CODE_CHAR(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) - -void -init_read(void) -{ - struct ecl_readtable_entry *rtab; - cl_object r, r_cmp; - int i; - - cl_core.standard_readtable = r = ecl_alloc_object(t_readtable); - r->readtable.locked = 0; - r->readtable.read_case = ecl_case_upcase; - r->readtable.table = rtab - = (struct ecl_readtable_entry *) - 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; - } -#ifdef ECL_UNICODE - r->readtable.hash = ECL_NIL; -#endif - - cl_core.dispatch_reader = make_cf2(dispatch_reader_fun); - - ecl_readtable_set(r, '\t', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, '\n', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, '\f', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, '\r', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, ' ', cat_whitespace, ECL_NIL); - - ecl_readtable_set(r, '"', cat_terminating, - make_cf2(double_quote_reader)); - - ecl_readtable_set(r, '\'', cat_terminating, - make_cf2(single_quote_reader)); - ecl_readtable_set(r, '(', cat_terminating, - make_cf2(left_parenthesis_reader)); - ecl_readtable_set(r, ')', cat_terminating, - make_cf2(right_parenthesis_reader)); - ecl_readtable_set(r, ',', cat_terminating, - make_cf2(comma_reader)); - ecl_readtable_set(r, ';', cat_terminating, - make_cf2(semicolon_reader)); - ecl_readtable_set(r, '\\', cat_single_escape, ECL_NIL); - ecl_readtable_set(r, '`', cat_terminating, - make_cf2(backquote_reader)); - ecl_readtable_set(r, '|', cat_multiple_escape, ECL_NIL); - - cl_make_dispatch_macro_character(3, ECL_CODE_CHAR('#'), - ECL_T /* non terminating */, r); - - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('C'), - make_cf3(sharp_C_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\\'), - make_cf3(sharp_backslash_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\''), - make_cf3(sharp_single_quote_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('('), - make_cf3(sharp_left_parenthesis_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('*'), - make_cf3(sharp_asterisk_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(':'), - make_cf3(sharp_colon_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('.'), - make_cf3(sharp_dot_reader), r); - /* Used for fasload only. */ - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('B'), - make_cf3(sharp_B_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('O'), - make_cf3(sharp_O_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('X'), - make_cf3(sharp_X_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('R'), - make_cf3(sharp_R_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('A'), - @'si::sharp-a-reader', r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('S'), - @'si::sharp-s-reader', r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('P'), - make_cf3(sharp_P_reader), r); - - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('='), - make_cf3(sharp_eq_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('#'), - make_cf3(sharp_sharp_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('+'), - make_cf3(sharp_plus_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('-'), - make_cf3(sharp_minus_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('|'), - make_cf3(sharp_vertical_bar_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\b'), - make_cf3(sharp_generic_error), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\t'), - make_cf3(sharp_generic_error), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(ECL_CHAR_CODE_NEWLINE), - make_cf3(sharp_generic_error), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(ECL_CHAR_CODE_LINEFEED), - make_cf3(sharp_generic_error), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\f'), - make_cf3(sharp_generic_error), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(ECL_CHAR_CODE_RETURN), - make_cf3(sharp_generic_error), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(' '), - make_cf3(sharp_generic_error), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(')'), - make_cf3(sharp_generic_error), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('<'), - make_cf3(sharp_generic_error), r); - /* This is specific to this implementation */ - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('$'), - make_cf3(sharp_dollar_reader), r); - /* This is specific to this implementation */ - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('Y'), - make_cf3(sharp_Y_reader), r); - /* This is specific to this implementation: ignore BOM */ -#ifdef ECL_UNICODE - ecl_readtable_set(r, 0xfeff, cat_whitespace, ECL_NIL); -#endif - - /* Lock the standard read table so that we do not have to make copies - * to keep it unchanged */ - r->readtable.locked = 1; - - r_cmp = ecl_copy_readtable(cl_core.standard_readtable, ECL_NIL); - /* This is specific to this implementation: syntax for base strings */ - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('"'), - make_cf3(sharp_double_quote_reader), r_cmp); - cl_core.compiler_readtable = r_cmp; - - init_backq(); - - ECL_SET(@'*readtable*', - r=ecl_copy_readtable(cl_core.standard_readtable, ECL_NIL)); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('!'), - ECL_NIL, r); - ECL_SET(@'*read-default-float-format*', @'single-float'); - - { - cl_object var, val; - var = cl_list(25, - @'*print-pprint-dispatch*', /* See end of pprint.lsp */ - @'*print-array*', - @'*print-base*', - @'*print-case*', - @'*print-circle*', - @'*print-escape*', - @'*print-gensym*', - @'*print-length*', - @'*print-level*', - @'*print-lines*', - @'*print-miser-width*', - @'*print-pretty*', - @'*print-radix*', - @'*print-readably*', - @'*print-right-margin*', - @'*read-base*', - @'*read-default-float-format*', - @'*read-eval*', - @'*read-suppress*', - @'*readtable*', - @'*package*', - @'si::*print-package*', - @'si::*print-structure*', - @'si::*sharp-eq-context*', - @'si::*circle-counter*'); - val = cl_list(25, - /**pprint-dispatch-table**/ ECL_NIL, - /**print-array**/ @'base-string', /* base string syntax */ - /**print-base**/ ecl_make_fixnum(10), - /**print-case**/ @':downcase', - /**print-circle**/ ECL_T, - /**print-escape**/ ECL_T, - /**print-gensym**/ ECL_T, - /**print-length**/ ECL_NIL, - /**print-level**/ ECL_NIL, - /**print-lines**/ ECL_NIL, - /**print-miser-width**/ ECL_NIL, - /**print-pretty**/ ECL_NIL, - /**print-radix**/ ECL_NIL, - /**print-readably**/ ECL_T, - /**print-right-margin**/ ECL_NIL, - /**read-base**/ ecl_make_fixnum(10), - /**read-default-float-format**/ @'single-float', - /**read-eval**/ ECL_T, - /**read-suppress**/ ECL_NIL, - /**readtable**/ cl_core.compiler_readtable, - /**package**/ cl_core.lisp_package, - /*si::*print-package**/ cl_core.lisp_package, - /*si::*print-structure**/ ECL_T, - /*si::*sharp-eq-context**/ ECL_NIL, - /*si::*cicle-counter**/ ECL_NIL); - ECL_SET(@'si::+ecl-syntax-progv-list+', CONS(var,val)); - var = cl_list(23, - @'*print-pprint-dispatch*', /* See end of pprint.lsp */ - @'*print-array*', - @'*print-base*', - @'*print-case*', - @'*print-circle*', - @'*print-escape*', - @'*print-gensym*', - @'*print-length*', - @'*print-level*', - @'*print-lines*', - @'*print-miser-width*', - @'*print-pretty*', - @'*print-radix*', - @'*print-readably*', - @'*print-right-margin*', - @'*read-base*', - @'*read-default-float-format*', - @'*read-eval*', - @'*read-suppress*', - @'*readtable*', - @'*package*', - @'si::*sharp-eq-context*', - @'si::*circle-counter*'); - val = cl_list(23, - /**pprint-dispatch-table**/ ECL_NIL, - /**print-array**/ ECL_T, - /**print-base**/ ecl_make_fixnum(10), - /**print-case**/ @':upcase', - /**print-circle**/ ECL_NIL, - /**print-escape**/ ECL_T, - /**print-gensym**/ ECL_T, - /**print-length**/ ECL_NIL, - /**print-level**/ ECL_NIL, - /**print-lines**/ ECL_NIL, - /**print-miser-width**/ ECL_NIL, - /**print-pretty**/ ECL_NIL, - /**print-radix**/ ECL_NIL, - /**print-readably**/ ECL_T, - /**print-right-margin**/ ECL_NIL, - /**read-base**/ ecl_make_fixnum(10), - /**read-default-float-format**/ @'single-float', - /**read-eval**/ ECL_T, - /**read-suppress**/ ECL_NIL, - /**readtable**/ cl_core.standard_readtable, - /**package**/ cl_core.user_package, - /*si::*sharp-eq-context**/ ECL_NIL, - /*si::*cicle-counter**/ ECL_NIL); - ECL_SET(@'si::+io-syntax-progv-list+', CONS(var,val)); - } -} - /* *---------------------------------------------------------------------- * diff --git a/src/c/reader/rtab_cl.d b/src/c/reader/rtab_cl.d new file mode 100644 index 000000000..f90abda7d --- /dev/null +++ b/src/c/reader/rtab_cl.d @@ -0,0 +1,1010 @@ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ + +/* + * rtab_cl.d -- readtable for Common Lisp + ECL extensions + * + * 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. + * + */ + +#include +#include +#include +#include +#include + +#define read_suppress (ecl_symbol_value(@'*read-suppress*') != ECL_NIL) + +#ifdef ECL_UNICODE +# define TOKEN_STRING_DIM(s) ((s)->string.dim) +# define TOKEN_STRING_FILLP(s) ((s)->string.fillp) +# define TOKEN_STRING_CHAR(s,n) ((s)->string.self[n]) +# define TOKEN_STRING_CHAR_SET(s,n,c) (s)->string.self[n]=(c) +# define TOKEN_STRING_CHAR_CMP(s,n,c) ((s)->string.self[n]==(c)) +#else +# define TOKEN_STRING_DIM(s) ((s)->base_string.dim) +# define TOKEN_STRING_FILLP(s) ((s)->base_string.fillp) +# define TOKEN_STRING_CHAR(s,n) ((s)->base_string.self[n]) +# define TOKEN_STRING_CHAR_SET(s,n,c) ((s)->base_string.self[n]=(c)) +# define TOKEN_STRING_CHAR_CMP(s,n,c) ((s)->base_string.self[n]==(c)) +#endif + +#define ECL_READ_ONLY_TOKEN 1 +#define ECL_READ_RETURN_IGNORABLE 3 +#define ECL_READ_LIST_DOT 4 + +static cl_object +right_parenthesis_reader(cl_object in, cl_object character) +{ + FEreader_error("Unmatched right parenthesis, #\\)", in, 0); +} + +static cl_object +left_parenthesis_reader(cl_object in, cl_object character) +{ + const char c = ')'; + @(return ecl_read_delimited_list(c, in, 0)); +} + +/* + * BACKQUOTE READER + */ + +static +cl_object comma_reader(cl_object in, cl_object c) +{ + cl_object x, y; + const cl_env_ptr env = ecl_process_env(); + cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(env, @'si::*backq-level*')); + + unlikely_if (backq_level <= 0 && !read_suppress) + FEreader_error("A comma has appeared out of a backquote.", in, 0); + /* Read character & complain at EOF */ + c = cl_peek_char(2,ECL_NIL,in); + if (c == ECL_CODE_CHAR('@@')) { + x = @'si::unquote-splice'; + ecl_read_char(in); + } else if (c == ECL_CODE_CHAR('.')) { + x = @'si::unquote-nsplice'; + ecl_read_char(in); + } else { + x = @'si::unquote'; + } + ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level-1)); + y = ecl_read_object(in); + ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); + return cl_list(2, x, y); +} + +static +cl_object backquote_reader(cl_object in, cl_object c) +{ + const cl_env_ptr the_env = ecl_process_env(); + cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(the_env, @'si::*backq-level*')); + ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level+1)); + c = ecl_read_object(in); + ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); + unlikely_if (c == OBJNULL) + FEend_of_file(in); + unlikely_if (read_suppress) + @(return ECL_NIL); +#if 0 + @(return cl_macroexpand_1(2, cl_list(2, @'si::quasiquote', in), ECL_NIL));; +#else + @(return cl_list(2,@'si::quasiquote',c)); +#endif +} + +static void +read_string_into_buffer(cl_object in, cl_object c, cl_object buffer) +{ + int delim = ECL_CHAR_CODE(c); + cl_object rtbl = ecl_current_readtable(); + for (;;) { + int c = ecl_read_char_noeof(in); + if (c == delim) + break; + else if (ecl_readtable_get(rtbl, c, NULL) == cat_single_escape) + c = ecl_read_char_noeof(in); + ecl_string_push_extend(buffer, c); + } +} + +static cl_object +double_quote_reader(cl_object in, cl_object c) +{ + cl_object output; + cl_object token = si_get_buffer_string(); + read_string_into_buffer(in, c, token); + /* Must be kept a SIMPLE-STRING, meaning a (SIMPLE-ARRAY CHARACTERS + * (*)), see CLHS 2.4.5. We thus can't coerce to a BASE-STRING. */ + output = cl_copy_seq(token); + si_put_buffer_string(token); + @(return output); +} + +static void +extra_argument(int c, cl_object stream, cl_object d) +{ + FEreader_error("~S is an extra argument for the #~C readmacro.", + stream, 2, d, ECL_CODE_CHAR(c)); +} + + +static cl_object +sharp_double_quote_reader(cl_object in, cl_object c, cl_object d) +{ + /* Base string reader. Used for data in compiled files. */ + cl_object s, token; + + if (d != ECL_NIL && !read_suppress) + extra_argument('"', in, d); + + token = si_get_buffer_string(); + read_string_into_buffer(in, c, token); + s = si_copy_to_simple_base_string(token); + si_put_buffer_string(token); + + if (read_suppress) + @(return ECL_NIL); + @(return s); +} + +static cl_object +single_quote_reader(cl_object in, cl_object c) +{ + c = ecl_read_object(in); + unlikely_if (c == OBJNULL) + FEend_of_file(in); + @(return cl_list(2, @'quote', c)); +} + +static cl_object +void_reader3(cl_object in, cl_object c, cl_object f) +{ + /* no result */ + @(return); +} + +static cl_object +semicolon_reader(cl_object in, cl_object c) +{ + int auxc; + + do + auxc = ecl_read_char(in); + while (auxc != '\n' && auxc != EOF); + /* no result */ + @(return); +} + +/* + sharpmacro routines +*/ + +static cl_object +sharp_generic_error(cl_object in, cl_object c, cl_object n) +{ + FEreader_error("The character ~:C is not a valid dispatch macro character", + in, 1, c); +} + +static cl_object +sharp_C_reader(cl_object in, cl_object c, cl_object d) +{ + const cl_env_ptr the_env = ecl_process_env(); + cl_object x, real, imag; + + if (d != ECL_NIL && !read_suppress) + extra_argument('C', in, d); + x = ecl_read_object(in); + unlikely_if (x == OBJNULL) + FEend_of_file(in); + if (read_suppress) + @(return ECL_NIL); + unlikely_if (!ECL_CONSP(x) || ecl_length(x) != 2) + FEreader_error("Reader macro #C should be followed by a list", + in, 0); + real = CAR(x); + imag = CADR(x); + /* INV: ecl_make_complex() checks its types. When reading circular + structures, we cannot check the types of the elements, and we + must build the complex number by hand. */ + if ((CONSP(real) || CONSP(imag)) && + !Null(ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'))) + { + x = ecl_alloc_object(t_complex); + x->gencomplex.real = real; + x->gencomplex.imag = imag; + } else { + x = ecl_make_complex(real, imag); + } + @(return x); +} + +static cl_object +sharp_backslash_reader(cl_object in, cl_object c, cl_object d) +{ + const cl_env_ptr the_env = ecl_process_env(); + cl_object token; + if (d != ECL_NIL && !read_suppress) { + unlikely_if (!ECL_FIXNUMP(d) || d != ecl_make_fixnum(0)) { + FEreader_error("~S is an illegal CHAR-FONT.", in, 1, d); + } + } + token = ecl_read_object_with_delimiter(in, EOF, ECL_READ_ONLY_TOKEN, + cat_single_escape); + if (token == ECL_NIL) { + c = ECL_NIL; + } else if (TOKEN_STRING_FILLP(token) == 1) { + c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,0)); + } else if (TOKEN_STRING_FILLP(token) == 2 && TOKEN_STRING_CHAR_CMP(token,0,'^')) { + /* #\^x */ + c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,1) & 037); + } else { + cl_object nc = cl_name_char(token); + unlikely_if (Null(nc)) { + FEreader_error("~S is an illegal character name.", in, 1, token); + } + c = nc; + } + si_put_buffer_string(token); + ecl_return1(the_env, c); +} + +static cl_object +sharp_single_quote_reader(cl_object in, cl_object c, cl_object d) +{ + bool suppress = read_suppress; + if(d != ECL_NIL && !suppress) + extra_argument('\'', in, d); + c = ecl_read_object(in); + unlikely_if (c == OBJNULL) { + FEend_of_file(in); + } else if (suppress) { + c = ECL_NIL; + } else { + c = cl_list(2, @'function', c); + } + @(return c); +} + +static cl_object +sharp_Y_reader(cl_object in, cl_object c, cl_object d) +{ + cl_index i; + cl_object x, rv, nth, lex; + + if (d != ECL_NIL && !read_suppress) + extra_argument('Y', in, d); + x = ecl_read_object(in); + unlikely_if (x == OBJNULL) { + FEend_of_file(in); + } + if (read_suppress) { + @(return ECL_NIL); + } + + unlikely_if (!ECL_CONSP(x) || ecl_length(x) < 5) { + FEreader_error("Reader macro #Y should be followed by a list", in, 0); + } + + rv = ecl_alloc_object(t_bytecodes); + + rv->bytecodes.name = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + + lex = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + + rv->bytecodes.definition = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + rv->bytecodes.code_size = ecl_to_fix(cl_list_length(nth)); + rv->bytecodes.code = ecl_alloc_atomic(rv->bytecodes.code_size * sizeof(uint16_t)); + for ( i=0; !ecl_endp(nth) ; i++, nth=ECL_CONS_CDR(nth) ) + ((cl_opcode*)(rv->bytecodes.code))[i] = ecl_to_fix(ECL_CONS_CAR(nth)); + + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + rv->bytecodes.data = nth; + + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + rv->bytecodes.flex = nth; + + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + rv->bytecodes.nlcl = nth; + + if (ECL_ATOM(x)) { + nth = ECL_NIL; + } else { + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + } + rv->bytecodes.file = nth; + if (ECL_ATOM(x)) { + nth = ecl_make_fixnum(0); + } else { + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + } + rv->bytecodes.file_position = nth; + + rv->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; + + if (lex != ECL_NIL) { + cl_object x = ecl_alloc_object(t_bclosure); + x->bclosure.code = rv; + x->bclosure.lex = lex; + x->bclosure.entry = _ecl_bclosure_dispatch_vararg; + rv = x; + } + @(return rv); +} + +#define QUOTE 1 +#define EVAL 2 +#define LIST 3 +#define LISTX 4 +#define APPEND 5 +#define NCONC 6 + +/* + *---------------------------------------------------------------------- + * Stack of unknown size + *---------------------------------------------------------------------- + */ + +cl_object +si_make_backq_vector(cl_object d, cl_object data, cl_object in) +{ + const cl_env_ptr the_env = ecl_process_env(); + cl_object v, last; + cl_index dim, i; + if (Null(d)) { + dim = ecl_length(data); + } else { + dim = ecl_fixnum(d); + } + v = ecl_alloc_simple_vector(dim, ecl_aet_object); + for (i = 0, last = ECL_NIL; i < dim; i++) { + if (data == ECL_NIL) { + /* ... we fill the vector with the last element read (or NIL). */ + for (; i < dim; i++) { + ecl_aset_unsafe(v, i, last); + } + break; + } + ecl_aset_unsafe(v, i, last = ecl_car(data)); + data = ECL_CONS_CDR(data); + } + unlikely_if (data != ECL_NIL) { + if (in != ECL_NIL) { + FEreader_error("Vector larger than specified length," + "~D.", in, 1, d); + } else { + FEerror("Vector larger than specified length, ~D", 1, d); + } + } + ecl_return1(the_env, v); +} + +static cl_object +sharp_left_parenthesis_reader(cl_object in, cl_object c, cl_object d) +{ + extern int _cl_backq_car(cl_object *); + const cl_env_ptr the_env = ecl_process_env(); + cl_object v; + unlikely_if (!Null(d) && + (!ECL_FIXNUMP(d) || ecl_fixnum_minusp(d) || + ecl_fixnum_greater(d, ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT)))) + { + FEreader_error("Invalid dimension size ~D in #()", in, 1, d); + } + if (ecl_fixnum_plusp(ECL_SYM_VAL(the_env, @'si::*backq-level*'))) { + /* First case: ther might be unquoted elements in the vector. + * Then we just create a form that generates the vector. + */ + cl_object x = ecl_read_delimited_list(')', in, 1); + cl_index a = _cl_backq_car(&x); + if (a != QUOTE) { + v = cl_list(2, @'si::unquote', + cl_list(4, @'si::make-backq-vector', d, x, ECL_NIL)); + } else { + return si_make_backq_vector(d, x, in); + } + } else if (read_suppress) { + /* Second case: *read-suppress* = t, we ignore the data */ + ecl_read_delimited_list(')', in, 1); + v = ECL_NIL; + } else if (Null(d)) { + /* Third case: no dimension provided. Read a list and + coerce it to vector. */ + return si_make_backq_vector(d, ecl_read_delimited_list(')', in, 1), in); + } else { + /* Finally: Both dimension and data are provided. The + amount of data cannot exceed the length, but it may + be smaller, and in that case...*/ + cl_object last; + cl_index dim = ecl_fixnum(d), i; + v = ecl_alloc_simple_vector(dim, ecl_aet_object); + for (i = 0, last = ECL_NIL;; i++) { + cl_object aux = ecl_read_object_with_delimiter(in, ')', 0, + cat_constituent); + if (aux == OBJNULL) + break; + unlikely_if (i >= dim) { + FEreader_error("Vector larger than specified length," + "~D.", in, 1, d); + } + ecl_aset_unsafe(v, i, last = aux); + } + /* ... we fill the vector with the last element read (or NIL). */ + for (; i < dim; i++) { + ecl_aset_unsafe(v, i, last); + } + } + @(return v); +} + +static cl_object +sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) +{ + cl_env_ptr env = ecl_process_env(); + cl_index sp = ECL_STACK_INDEX(env); + cl_object last, elt, x; + cl_fixnum dim, dimcount, i; + cl_object rtbl = ecl_current_readtable(); + enum ecl_chattrib a; + + if (read_suppress) { + ecl_read_constituent(in, 1); + @(return ECL_NIL); + } + for (dimcount = 0 ;; dimcount++) { + int x = ecl_read_char(in); + if (x == EOF) + break; + a = ecl_readtable_get(rtbl, x, NULL); + if (a == cat_terminating || a == cat_whitespace) { + ecl_unread_char(x, in); + break; + } + unlikely_if (a == cat_single_escape || a == cat_multiple_escape || + (x != '0' && x != '1')) + { + FEreader_error("Character ~:C is not allowed after #*", + in, 1, ECL_CODE_CHAR(x)); + } + ECL_STACK_PUSH(env, ecl_make_fixnum(x == '1')); + } + if (Null(d)) { + dim = dimcount; + } else { + unlikely_if (!ECL_FIXNUMP(d) || ((dim = ecl_fixnum(d)) < 0) || + (dim > ECL_ARRAY_DIMENSION_LIMIT)) + { + FEreader_error("Wrong vector dimension size ~D in #*.", + in, 1, d); + } + unlikely_if (dimcount > dim) + FEreader_error("Too many elements in #*.", in, 0); + unlikely_if (dim && (dimcount == 0)) + FEreader_error("Cannot fill the bit-vector #*.", in, 0); + } + last = ECL_STACK_REF(env,-1); + x = ecl_alloc_simple_vector(dim, ecl_aet_bit); + for (i = 0; i < dim; i++) { + elt = (i < dimcount) ? env->run_stack.org[sp+i] : last; + if (elt == ecl_make_fixnum(0)) + x->vector.self.bit[i/CHAR_BIT] &= ~(0200 >> i%CHAR_BIT); + else + x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT; + } + ECL_STACK_POP_N_UNSAFE(env, dimcount); + @(return x); +} + +static cl_object +sharp_colon_reader(cl_object in, cl_object ch, cl_object d) +{ + cl_object rtbl = ecl_current_readtable(); + enum ecl_chattrib a; + int c; + cl_object output, token; + + if (d != ECL_NIL && !read_suppress) + extra_argument(':', in, d); + c = ecl_read_char_noeof(in); + a = ecl_readtable_get(rtbl, c, NULL); + token = si_get_buffer_string(); + goto L; + for (;;) { + ecl_string_push_extend(token, c); + K: + c = ecl_read_char(in); + if (c == EOF) + goto M; + a = ecl_readtable_get(rtbl, c, NULL); + L: + if (a == cat_single_escape) { + c = ecl_read_char_noeof(in); + a = cat_constituent; + } else if (a == cat_multiple_escape) { + for (;;) { + c = ecl_read_char_noeof(in); + a = ecl_readtable_get(rtbl, c, NULL); + if (a == cat_single_escape) { + c = ecl_read_char_noeof(in); + a = cat_constituent; + } else if (a == cat_multiple_escape) + break; + ecl_string_push_extend(token, c); + } + goto K; + } else if (ecl_lower_case_p(c)) { + c = ecl_char_upcase(c); + } else if (c == ':' && !read_suppress) { + FEreader_error("An uninterned symbol must not contain a package prefix", in, 0); + } + if (a == cat_whitespace || a == cat_terminating) + break; + } + ecl_unread_char(c, in); + + M: + if (read_suppress) { + output = ECL_NIL; + } else { + output = cl_make_symbol(token); + } + si_put_buffer_string(token); + @(return output); +} + +static cl_object +sharp_dot_reader(cl_object in, cl_object c, cl_object d) +{ + const cl_env_ptr the_env = ecl_process_env(); + if (d != ECL_NIL && !read_suppress) + extra_argument('.', in, d); + c = ecl_read_eval(in); + ecl_return1(the_env, c); +} + +static cl_object +read_number(cl_object in, int radix, cl_object macro_char) +{ + cl_index i; + cl_object x; + /* ecl_read_constituent is called with not_first=true, because we are called + by reader macros for composite tokens, like #x123. -- jd 2024-05-12 */ + cl_object token = ecl_read_constituent(in, 1); + if (token == ECL_NIL) { + x = ECL_NIL; + } else { + x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, radix); + unlikely_if (x == OBJNULL || x == ECL_NIL || + i != TOKEN_STRING_FILLP(token)) + { + FEreader_error("Cannot parse the #~A readmacro.", in, 1, + macro_char); + } + unlikely_if (cl_rationalp(x) == ECL_NIL) { + FEreader_error("The float ~S appeared after the #~A readmacro.", + in, 2, x, macro_char); + } + si_put_buffer_string(token); + } + return x; +} + +static cl_object +sharp_B_reader(cl_object in, cl_object c, cl_object d) +{ + if(d != ECL_NIL && !read_suppress) + extra_argument('B', in, d); + @(return (read_number(in, 2, ECL_CODE_CHAR('B')))); +} + +static cl_object +sharp_O_reader(cl_object in, cl_object c, cl_object d) +{ + if(d != ECL_NIL && !read_suppress) + extra_argument('O', in, d); + @(return (read_number(in, 8, ECL_CODE_CHAR('O')))); +} + +static cl_object +sharp_X_reader(cl_object in, cl_object c, cl_object d) +{ + if(d != ECL_NIL && !read_suppress) + extra_argument('X', in, d); + @(return (read_number(in, 16, ECL_CODE_CHAR('X')))); +} + +static cl_object +sharp_R_reader(cl_object in, cl_object c, cl_object d) +{ + int radix; + if (read_suppress) { + radix = 10; + } else unlikely_if (!ECL_FIXNUMP(d)) { + FEreader_error("No radix was supplied in the #R readmacro.", in, 0); + } else { + radix = ecl_fixnum(d); + unlikely_if (radix > 36 || radix < 2) { + FEreader_error("~S is an illegal radix.", in, 1, d); + } + } + @(return (read_number(in, radix, ECL_CODE_CHAR('R')))); +} + +static cl_object +sharp_eq_reader(cl_object in, cl_object c, cl_object d) +{ + const cl_env_ptr the_env = ecl_process_env(); + cl_object pair, value; + cl_object sharp_eq_context = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); + + if (read_suppress) { + @(return); + } + unlikely_if (Null(d)) { + FEreader_error("The #= readmacro requires an argument.", in, 0); + } + unlikely_if (ecl_assq(d, sharp_eq_context) != ECL_NIL) { + FEreader_error("Duplicate definitions for #~D=.", in, 1, d); + } + pair = CONS(d, OBJNULL); + ECL_SETQ(the_env, @'si::*sharp-eq-context*', CONS(pair, sharp_eq_context)); + value = ecl_read_object(in); + unlikely_if (value == pair) { + FEreader_error("#~D# is defined by itself.", in, 1, d); + } + ECL_RPLACD(pair, value); + ecl_return1(the_env, value); +} + +static cl_object +sharp_sharp_reader(cl_object in, cl_object c, cl_object d) +{ + const cl_env_ptr the_env = ecl_process_env(); + cl_object pair; + + if (read_suppress) + ecl_return1(the_env, ECL_NIL); + unlikely_if (Null(d)) { + FEreader_error("The ## readmacro requires an argument.", in, 0); + } + pair = ecl_assq(d, ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*')); + unlikely_if (pair == ECL_NIL) { + FEreader_error("#~D# is undefined.", in, 1, d); + } else { + cl_object value = ECL_CONS_CDR(pair); + ecl_return1(the_env, (value == OBJNULL)? pair : value); + } +} + +#define sharp_plus_reader void_reader3 +#define sharp_minus_reader void_reader3 + +static cl_object +sharp_vertical_bar_reader(cl_object in, cl_object ch, cl_object d) +{ + int c; + int level = 0; + + if (d != ECL_NIL && !read_suppress) + extra_argument('|', in, d); + for (;;) { + c = ecl_read_char_noeof(in); + L: + if (c == '#') { + c = ecl_read_char_noeof(in); + if (c == '|') + level++; + } else if (c == '|') { + c = ecl_read_char_noeof(in); + if (c == '#') { + if (level == 0) + break; + else + --level; + } else + goto L; + } + } + /* no result */ + @(return); +} + +/* + #P" ... " returns the pathname with namestring ... . +*/ +static cl_object +sharp_P_reader(cl_object in, cl_object c, cl_object d) +{ + bool suppress = read_suppress; + if (d != ECL_NIL && !suppress) + extra_argument('P', in, d); + d = ecl_read_object(in); + if (suppress) { + d = ECL_NIL; + } else { + d = cl_parse_namestring(3, d, ECL_NIL, ECL_NIL); + } + @(return d); +} + +/* + #$ fixnum returns a random-state with the fixnum + as its content. +*/ +static cl_object +sharp_dollar_reader(cl_object in, cl_object c, cl_object d) +{ + cl_object rs; + if (d != ECL_NIL && !read_suppress) + extra_argument('$', in, d); + c = ecl_read_object(in); + rs = ecl_make_random_state(c); + + @(return rs); +} + +#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) + +void +init_read(void) +{ + struct ecl_readtable_entry *rtab; + cl_object r, r_cmp; + int i; + + cl_core.standard_readtable = r = ecl_alloc_object(t_readtable); + r->readtable.locked = 0; + r->readtable.read_case = ecl_case_upcase; + r->readtable.table = rtab + = (struct ecl_readtable_entry *) + 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; + } +#ifdef ECL_UNICODE + r->readtable.hash = ECL_NIL; +#endif + + cl_core.dispatch_reader = make_cf2(ecl_dispatch_reader_fun); + + ecl_readtable_set(r, '\t', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, '\n', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, '\f', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, '\r', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, ' ', cat_whitespace, ECL_NIL); + + ecl_readtable_set(r, '"', cat_terminating, + make_cf2(double_quote_reader)); + + ecl_readtable_set(r, '\'', cat_terminating, + make_cf2(single_quote_reader)); + ecl_readtable_set(r, '(', cat_terminating, + make_cf2(left_parenthesis_reader)); + ecl_readtable_set(r, ')', cat_terminating, + make_cf2(right_parenthesis_reader)); + ecl_readtable_set(r, ',', cat_terminating, + make_cf2(comma_reader)); + ecl_readtable_set(r, ';', cat_terminating, + make_cf2(semicolon_reader)); + ecl_readtable_set(r, '\\', cat_single_escape, ECL_NIL); + ecl_readtable_set(r, '`', cat_terminating, + make_cf2(backquote_reader)); + ecl_readtable_set(r, '|', cat_multiple_escape, ECL_NIL); + + cl_make_dispatch_macro_character(3, ECL_CODE_CHAR('#'), + ECL_T /* non terminating */, r); + + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('C'), + make_cf3(sharp_C_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\\'), + make_cf3(sharp_backslash_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\''), + make_cf3(sharp_single_quote_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('('), + make_cf3(sharp_left_parenthesis_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('*'), + make_cf3(sharp_asterisk_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(':'), + make_cf3(sharp_colon_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('.'), + make_cf3(sharp_dot_reader), r); + /* Used for fasload only. */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('B'), + make_cf3(sharp_B_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('O'), + make_cf3(sharp_O_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('X'), + make_cf3(sharp_X_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('R'), + make_cf3(sharp_R_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('A'), + @'si::sharp-a-reader', r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('S'), + @'si::sharp-s-reader', r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('P'), + make_cf3(sharp_P_reader), r); + + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('='), + make_cf3(sharp_eq_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('#'), + make_cf3(sharp_sharp_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('+'), + make_cf3(sharp_plus_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('-'), + make_cf3(sharp_minus_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('|'), + make_cf3(sharp_vertical_bar_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\b'), + make_cf3(sharp_generic_error), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\t'), + make_cf3(sharp_generic_error), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(ECL_CHAR_CODE_NEWLINE), + make_cf3(sharp_generic_error), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(ECL_CHAR_CODE_LINEFEED), + make_cf3(sharp_generic_error), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\f'), + make_cf3(sharp_generic_error), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(ECL_CHAR_CODE_RETURN), + make_cf3(sharp_generic_error), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(' '), + make_cf3(sharp_generic_error), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(')'), + make_cf3(sharp_generic_error), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('<'), + make_cf3(sharp_generic_error), r); + /* This is specific to this implementation */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('$'), + make_cf3(sharp_dollar_reader), r); + /* This is specific to this implementation */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('Y'), + make_cf3(sharp_Y_reader), r); + /* This is specific to this implementation: ignore BOM */ +#ifdef ECL_UNICODE + ecl_readtable_set(r, 0xfeff, cat_whitespace, ECL_NIL); +#endif + + /* Lock the standard read table so that we do not have to make copies + * to keep it unchanged */ + r->readtable.locked = 1; + + r_cmp = ecl_copy_readtable(cl_core.standard_readtable, ECL_NIL); + /* This is specific to this implementation: syntax for base strings */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('"'), + make_cf3(sharp_double_quote_reader), r_cmp); + cl_core.compiler_readtable = r_cmp; + + init_backq(); + + ECL_SET(@'*readtable*', + r=ecl_copy_readtable(cl_core.standard_readtable, ECL_NIL)); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('!'), + ECL_NIL, r); + ECL_SET(@'*read-default-float-format*', @'single-float'); + + { + cl_object var, val; + var = cl_list(25, + @'*print-pprint-dispatch*', /* See end of pprint.lsp */ + @'*print-array*', + @'*print-base*', + @'*print-case*', + @'*print-circle*', + @'*print-escape*', + @'*print-gensym*', + @'*print-length*', + @'*print-level*', + @'*print-lines*', + @'*print-miser-width*', + @'*print-pretty*', + @'*print-radix*', + @'*print-readably*', + @'*print-right-margin*', + @'*read-base*', + @'*read-default-float-format*', + @'*read-eval*', + @'*read-suppress*', + @'*readtable*', + @'*package*', + @'si::*print-package*', + @'si::*print-structure*', + @'si::*sharp-eq-context*', + @'si::*circle-counter*'); + val = cl_list(25, + /**pprint-dispatch-table**/ ECL_NIL, + /**print-array**/ @'base-string', /* base string syntax */ + /**print-base**/ ecl_make_fixnum(10), + /**print-case**/ @':downcase', + /**print-circle**/ ECL_T, + /**print-escape**/ ECL_T, + /**print-gensym**/ ECL_T, + /**print-length**/ ECL_NIL, + /**print-level**/ ECL_NIL, + /**print-lines**/ ECL_NIL, + /**print-miser-width**/ ECL_NIL, + /**print-pretty**/ ECL_NIL, + /**print-radix**/ ECL_NIL, + /**print-readably**/ ECL_T, + /**print-right-margin**/ ECL_NIL, + /**read-base**/ ecl_make_fixnum(10), + /**read-default-float-format**/ @'single-float', + /**read-eval**/ ECL_T, + /**read-suppress**/ ECL_NIL, + /**readtable**/ cl_core.compiler_readtable, + /**package**/ cl_core.lisp_package, + /*si::*print-package**/ cl_core.lisp_package, + /*si::*print-structure**/ ECL_T, + /*si::*sharp-eq-context**/ ECL_NIL, + /*si::*cicle-counter**/ ECL_NIL); + ECL_SET(@'si::+ecl-syntax-progv-list+', CONS(var,val)); + var = cl_list(23, + @'*print-pprint-dispatch*', /* See end of pprint.lsp */ + @'*print-array*', + @'*print-base*', + @'*print-case*', + @'*print-circle*', + @'*print-escape*', + @'*print-gensym*', + @'*print-length*', + @'*print-level*', + @'*print-lines*', + @'*print-miser-width*', + @'*print-pretty*', + @'*print-radix*', + @'*print-readably*', + @'*print-right-margin*', + @'*read-base*', + @'*read-default-float-format*', + @'*read-eval*', + @'*read-suppress*', + @'*readtable*', + @'*package*', + @'si::*sharp-eq-context*', + @'si::*circle-counter*'); + val = cl_list(23, + /**pprint-dispatch-table**/ ECL_NIL, + /**print-array**/ ECL_T, + /**print-base**/ ecl_make_fixnum(10), + /**print-case**/ @':upcase', + /**print-circle**/ ECL_NIL, + /**print-escape**/ ECL_T, + /**print-gensym**/ ECL_T, + /**print-length**/ ECL_NIL, + /**print-level**/ ECL_NIL, + /**print-lines**/ ECL_NIL, + /**print-miser-width**/ ECL_NIL, + /**print-pretty**/ ECL_NIL, + /**print-radix**/ ECL_NIL, + /**print-readably**/ ECL_T, + /**print-right-margin**/ ECL_NIL, + /**read-base**/ ecl_make_fixnum(10), + /**read-default-float-format**/ @'single-float', + /**read-eval**/ ECL_T, + /**read-suppress**/ ECL_NIL, + /**readtable**/ cl_core.standard_readtable, + /**package**/ cl_core.user_package, + /*si::*sharp-eq-context**/ ECL_NIL, + /*si::*cicle-counter**/ ECL_NIL); + ECL_SET(@'si::+io-syntax-progv-list+', CONS(var,val)); + } +} diff --git a/src/h/external.h b/src/h/external.h index c92947a3f..ed987f3ca 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1571,7 +1571,12 @@ extern ECL_API cl_object si_make_backq_vector(cl_object dim, cl_object data, cl_ 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 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); +extern ECL_API cl_object ecl_read_eval(cl_object in); extern ECL_API cl_object ecl_read_object_non_recursive(cl_object in); +extern ECL_API cl_object ecl_read_object_with_delimiter(cl_object in, int del, int flags, enum ecl_chattrib a); extern ECL_API cl_object ecl_read_object(cl_object in); extern ECL_API cl_object ecl_parse_number(cl_object s, cl_index start, cl_index end, cl_index *ep, unsigned int radix); extern ECL_API cl_object ecl_parse_integer(cl_object s, cl_index start, cl_index end, cl_index *ep, unsigned int radix);