diff --git a/src/CHANGELOG b/src/CHANGELOG index 38f21ff38..1f21b1a08 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -7,6 +7,9 @@ ECL 1.0 produced by "ln -sf ../tmp/foo faa") are now properly recognized and followed by TRUENAME. + - The routines for writing bignums had a size limit that has been + removed. Besides the library does not rely on GMP for printing bignums. + * Visible changes: - SI:MKSTEMP now accepts and returns pathnames. @@ -20,6 +23,9 @@ ECL 1.0 - The value of *READTABLE* can now be modified by the user. + - Implemented READTABLE-CASE, including the appropiate changes to the + reader and the printer. + ;;; Local Variables: *** ;;; mode:text *** ;;; fill-column:79 *** diff --git a/src/c/character.d b/src/c/character.d index 8027f4ccb..24116764c 100644 --- a/src/c/character.d +++ b/src/c/character.d @@ -71,6 +71,26 @@ cl_both_case_p(cl_object c) @(return ((isupper(code) || islower(code)) ? Ct : Cnil)) } +int +ecl_string_case(cl_object s) +{ + int upcase; + cl_index i; + const char *text; + for (i = 0, upcase = 0, text = s->string.self; i <= s->string.dim; i++) { + if (isupper(text[i])) { + if (upcase < 0) + return 0; + upcase = +1; + } else if (islower(text[i])) { + if (upcase > 0) + return 0; + upcase = -1; + } + } + return upcase; +} + #define basep(d) (d <= 36) @(defun digit_char_p (c &optional (r MAKE_FIXNUM(10))) diff --git a/src/c/num_log.d b/src/c/num_log.d index 906c95122..32fc80734 100644 --- a/src/c/num_log.d +++ b/src/c/num_log.d @@ -467,8 +467,8 @@ ecl_ash(cl_object x, cl_fixnum w) return(big_register_normalize(y)); } -static int -int_bit_length(cl_fixnum i) +int +ecl_fixnum_bit_length(cl_fixnum i) { int count; if (i < 0) @@ -644,7 +644,7 @@ cl_integer_length(cl_object x) switch (type_of(x)) { case t_fixnum: i = fix(x); - count = int_bit_length(i); + count = ecl_fixnum_bit_length(i); break; case t_bignum: if (mpz_sgn(x->big.big_num) < 0) diff --git a/src/c/pathname.d b/src/c/pathname.d index 2a66ca950..c5113b94a 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -185,30 +185,6 @@ static int is_semicolon(int c) { return c == ';'; } static int is_dot(int c) { return c == '.'; } static int is_null(int c) { return c == '\0'; } -static int -is_all_upper(cl_object s) -{ - cl_index i; - const char *text; - for (i = 0, text = s->string.self; i <= s->string.dim; i++) { - if (!isupper(text[i])) - return 0; - } - return 1; -} - -static int -is_all_lower(cl_object s) -{ - cl_index i; - const char *text; - for (i = 0, text = s->string.self; i <= s->string.dim; i++) { - if (!islower(text[i])) - return 0; - } - return 1; -} - /* * Translates a string into the host's preferred case. * See CLHS 19.2.2.1.2.2 Common Case in Pathname Components. @@ -217,17 +193,20 @@ is_all_lower(cl_object s) static cl_object translate_common_case(cl_object str) { + int string_case; if (type_of(str) != t_string) { /* Pathnames may contain some other objects, such as symbols, * numbers, etc, which need not be translated */ return str; - } else if (is_all_upper(str)) { + } + string_case = ecl_string_case(str); + if (string_case > 0) { /* ALL_UPPER */ /* We use UN*X conventions, so lower case is default. * However, this really should be conditionalised to the OS type, * and it should translate to the _local_ case. */ return cl_string_downcase(1, str); - } else if (is_all_lower(str)) { + } else if (string_case < 0) { /* ALL_LOWER */ /* We use UN*X conventions, so lower case is default. * However, this really should be conditionalised to the OS type, * and it should translate to _opposite_ of the local case. diff --git a/src/c/print.d b/src/c/print.d index 91c17be44..75da2b3b6 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -386,22 +386,29 @@ write_str(const char *s, cl_object stream) } static void -write_decimal1(cl_object stream, cl_fixnum i) +write_positive_fixnum(cl_index i, int base, cl_index len, cl_object stream) { - if (i == 0) - return; - write_decimal1(stream, i/10); - write_ch(i%10 + '0', stream); + /* The maximum number of digits is achieved for base 2 and it + is always < FIXNUM_BITS, since we use at least one bit for + tagging */ + short digits[FIXNUM_BITS]; + int j = 0; + if (i == 0) { + digits[j++] = '0'; + } else do { + digits[j++] = ecl_digit_char(i % base, base); + i /= base; + } while (i > 0); + while (len-- > j) + write_ch('0', stream); + while (j-- > 0) + write_ch(digits[j], stream); } static void write_decimal(cl_fixnum i, cl_object stream) { - if (i == 0) { - write_ch('0', stream); - return; - } - write_decimal1(stream, i); + return write_positive_fixnum(i, 10, 0, stream); } static void @@ -496,7 +503,6 @@ edit_double(int n, double d, int *sp, char *s, int *ep) s[n] = '\0'; } - static void write_double(double d, int e, bool shortp, cl_object stream) { @@ -574,133 +580,185 @@ write_double(double d, int e, bool shortp, cl_object stream) } +struct powers { + cl_object number; + cl_index n_digits; + int base; +}; + static void -write_positive_fixnum(cl_index i, cl_object stream) +do_write_integer(cl_object x, struct powers *powers, cl_index len, + cl_object stream) { - /* The maximum number of digits is achieved for base 2 and it - is always < FIXNUM_BITS, since we use at least one bit for - tagging */ - short digits[FIXNUM_BITS]; - int j, base = ecl_print_base(); - for (j = 0; i != 0; i /= base) - digits[j++] = ecl_digit_char(i % base, base); - while (j-- > 0) - write_ch(digits[j], stream); + cl_object left; + do { + if (FIXNUMP(x)) { + write_positive_fixnum(fix(x), powers->base, len, stream); + return; + } + while (number_compare(x, powers->number) < 0) { + if (len) + write_positive_fixnum(0, powers->base, len, stream); + powers--; + } + floor2(x, powers->number); + left = VALUES(0); + x = VALUES(1); + if (len) len -= powers->n_digits; + do_write_integer(left, powers-1, len, stream); + len = powers->n_digits; + powers--; + } while(1); } static void write_bignum(cl_object x, cl_object stream) { int base = ecl_print_base(); - cl_fixnum str_size = mpz_sizeinbase(x->big.big_num, base); + cl_index str_size = mpz_sizeinbase(x->big.big_num, base); + cl_fixnum num_powers = ecl_fixnum_bit_length(str_size-1); #ifdef __GNUC__ - char str[str_size+2]; + struct powers powers[num_powers]; #else - char *str = (char*)malloc(sizeof(char)*(str_size+2)); + struct powers *powers = malloc(sizeof(struct powers)*num_powers); CL_UNWIND_PROTECT_BEGIN { #endif - char *s = str; - mpz_get_str(str, base, x->big.big_num); - while (*s) - write_ch(*s++, stream); + cl_object p; + cl_index i, n_digits; + powers[0].number = p = MAKE_FIXNUM(base); + powers[0].n_digits = n_digits = 1; + powers[0].base = base; + for (i = 1; i < num_powers; i++) { + powers[i].number = p = number_times(p, p); + powers[i].n_digits = n_digits = 2*n_digits; + powers[i].base = base; + } + if (number_minusp(x)) { + write_ch('-', stream); + x = number_negate(x); + } + do_write_integer(x, &powers[num_powers-1], 0, stream); #ifndef __GNUC__ } CL_UNWIND_PROTECT_EXIT { - free(str); + free(str); } CL_UNWIND_PROTECT_END; #endif } +static bool +all_dots(cl_object s) +{ + cl_index i; + for (i = 0; i < s->string.fillp; i++) + if (s->string.self[i] != '.') + return 0; + return 1; +} + +static bool +needs_to_be_escaped(cl_object s, cl_object readtable, cl_object print_case) +{ + enum ecl_readtable_case action = readtable->readtable.read_case; + bool all_dots; + cl_index i; + if (potential_number_p(s, ecl_print_base())) + return 1; + for (i = 0; i < s->string.fillp; i++) { + int c = s->string.self[i] & 0377; + int syntax = readtable->readtable.table[c].syntax_type; + if (syntax != cat_constituent || (c) == ':') + return 1; + if ((action == ecl_case_downcase) && isupper(c)) + return 1; + if ((action == ecl_case_upcase) && islower(c)) + return 1; + } + return 0; +} + +#define needs_to_be_inverted(s) (ecl_string_case(s) != 0) + +static void +write_symbol_string(cl_object s, cl_object readtable, cl_object print_case, + cl_object stream, bool escape) +{ + enum ecl_readtable_case action = readtable->readtable.read_case; + cl_index i; + if (action == ecl_case_invert) { + if (!needs_to_be_inverted(s)) + action = ecl_case_preserve; + } + if (escape) + write_ch('|', stream); + for (i = 0; i < s->string.fillp; i++) { + int c = s->string.self[i]; + if (escape) { + if (c == '|' || c == '\\') { + write_ch('\\', stream); + } + } else if (action != ecl_case_preserve) { + if (isupper(c)) { + if ((action == ecl_case_invert) || + (print_case == @':downcase') || + ((print_case == @':capitalize') && (i > 0))) + { + c = tolower(c); + } + } else if (islower(c)) { + if ((action == ecl_case_invert) || + (print_case == @':upcase') || + ((print_case == @':capitalize') && (i == 0))) + { + c = toupper(c); + } + } + } + write_ch(c, stream); + } + if (escape) + write_ch('|', stream); +} + static void write_symbol(cl_object x, cl_object stream) { - bool escaped; - cl_index i; - cl_object s = x->symbol.name; cl_object print_package = symbol_value(@'si::*print-package*'); cl_object print_case = ecl_print_case(); + cl_object readtable = ecl_current_readtable(); + cl_object package = x->symbol.hpack; + cl_object name = x->symbol.name; int intern_flag; if (!ecl_print_escape() && !ecl_print_readably()) { - for (i = 0; i < s->string.fillp; i++) { - int c = s->string.self[i]; - if (isupper(c) && - (print_case == @':downcase' || - (print_case == @':capitalize' && i != 0))) - c = tolower(c); - write_ch(c, stream); - } + write_symbol_string(name, readtable, print_case, stream, 0); return; } - if (Null(x->symbol.hpack)) { + if (Null(package)) { if (ecl_print_gensym()) write_str("#:", stream); - } else if (x->symbol.hpack == cl_core.keyword_package) + } else if (package == cl_core.keyword_package) { write_ch(':', stream); - else if ((print_package != Cnil && x->symbol.hpack != print_package) - || ecl_find_symbol(x, current_package(), &intern_flag)!=x - || intern_flag == 0) { - escaped = 0; - for (i = 0; - i < x->symbol.hpack->pack.name->string.fillp; - i++) { - int c = x->symbol.hpack->pack.name->string.self[i]; - if (to_be_escaped(c)) - escaped = 1; - } - if (escaped) - write_ch('|', stream); - for (i = 0; - i < x->symbol.hpack->pack.name->string.fillp; - i++) { - int c = x->symbol.hpack->pack.name->string.self[i]; - if (c == '|' || c == '\\') - write_ch('\\', stream); - if (escaped == 0 && isupper(c) && - (print_case == @':downcase' || - (print_case == @':capitalize' && i!=0))) - c = tolower(c); - write_ch(c, stream); - } - if (escaped) - write_ch('|', stream); - if (ecl_find_symbol(x, x->symbol.hpack, &intern_flag) != x) + } else if ((print_package != Cnil && package != print_package) + || ecl_find_symbol(x, current_package(), &intern_flag)!=x + || intern_flag == 0) + { + cl_object name = package->pack.name; + write_symbol_string(name, readtable, print_case, stream, + needs_to_be_escaped(name, readtable, print_case)); + if (ecl_find_symbol(x, package, &intern_flag) != x) error("can't print symbol"); - if ((print_package != Cnil && x->symbol.hpack != print_package) - || intern_flag == INTERNAL) + if ((print_package != Cnil && package != print_package) + || intern_flag == INTERNAL) { write_str("::", stream); - else if (intern_flag == EXTERNAL) + } else if (intern_flag == EXTERNAL) { write_ch(':', stream); - else + } else { FEerror("Pathological symbol --- cannot print.", 0); + } } - escaped = 0; - if (potential_number_p(s, ecl_print_base())) - escaped = 1; - for (i = 0; i < s->string.fillp; i++) { - int c = s->string.self[i]; - if (to_be_escaped(c)) - escaped = 1; - } - for (i = 0; i < s->string.fillp; i++) - if (s->string.self[i] != '.') - goto NOT_DOT; - escaped = 1; - - NOT_DOT: - if (escaped) - write_ch('|', stream); - for (i = 0; i < s->string.fillp; i++) { - int c = s->string.self[i]; - if (c == '|' || c == '\\') - write_ch('\\', stream); - if (escaped == 0 && isupper(c) && - (print_case == @':downcase' || - (print_case == @':capitalize' && i != 0))) - c = tolower(c); - write_ch(c, stream); - } - if (escaped) - write_ch('|', stream); + write_symbol_string(name, readtable, print_case, stream, + needs_to_be_escaped(name, readtable, print_case) || + all_dots(name)); } static void @@ -753,9 +811,9 @@ si_write_ugly_object(cl_object x, cl_object stream) write_ch('0', stream); } else if (FIXNUM_MINUSP(x)) { write_ch('-', stream); - write_positive_fixnum(-fix(x), stream); + write_positive_fixnum(-fix(x), print_base, 0, stream); } else { - write_positive_fixnum(fix(x), stream); + write_positive_fixnum(fix(x), print_base, 0, stream); } if (print_radix && print_base == 10) { write_ch('.', stream); diff --git a/src/c/read.d b/src/c/read.d index 381cf7d44..9a43c67ed 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -59,6 +59,45 @@ read_object_non_recursive(cl_object in) return(x); } +/* + * This routine inverts the case of the characters in the buffer which + * were not escaped. ESCAPE_LIST is a list of intevals of characters + * that were escaped, as in ({(low-limit . high-limit)}*). The list + * goes from the last interval to the first one, in reverse order, + * and thus we run the buffer from the end to the beginning. + */ +static void +invert_buffer_case(cl_object x, cl_object escape_list, int sign) +{ + cl_fixnum high_limit, low_limit; + cl_object escape_interval; + cl_fixnum i = x->string.fillp; + do { + if (escape_list != Cnil) { + cl_object escape_interval = CAR(escape_list); + high_limit = fix(CAR(escape_interval)); + low_limit = fix(CDR(escape_interval)); + escape_list = CDR(escape_list); + } else { + high_limit = low_limit = -1; + } + for (; i > high_limit; i--) { + /* The character is not escaped */ + char c = x->string.self[i]; + if (isupper(c) && (sign < 0)) { + c = tolower(c); + } else if (islower(c) && (sign > 0)) { + c = toupper(c); + } + x->string.self[i] = c; + } + for (; i > low_limit; i--) { + /* The character is within an escaped interval */ + ; + } + } while (i >= 0); +} + static cl_object read_object_with_delimiter(cl_object in, int delimiter) { @@ -68,11 +107,13 @@ read_object_with_delimiter(cl_object in, int delimiter) cl_object p; cl_index length, i, colon; int colon_type, intern_flag; - bool escape_flag; cl_object rtbl = ecl_current_readtable(); + enum ecl_readtable_case read_case = rtbl->readtable.read_case; + cl_object escape_list; /* intervals of escaped characters */ + cl_fixnum upcase; /* # uppercase characters - # downcase characters */ + cl_fixnum count; /* number of unescaped characters */ BEGIN: - /* Beppe: */ do { c = ecl_getc(in); if (c == EOF || c == delimiter) @@ -87,17 +128,23 @@ BEGIN: 2, x, MAKE_FIXNUM(i)); return o; } - escape_flag = FALSE; - length = 0; + escape_list = Cnil; + upcase = count = length = 0; colon_type = 0; cl_env.token->string.fillp = 0; for (;;) { if (a == cat_single_escape) { c = ecl_getc_noeof(in); a = cat_constituent; - escape_flag = TRUE; + if (read_case == ecl_case_invert) { + escape_list = CONS(CONS(MAKE_FIXNUM(length), + MAKE_FIXNUM(length)), + escape_list); + } + ecl_string_push_extend(cl_env.token, c); + length++; } else if (a == cat_multiple_escape) { - escape_flag = TRUE; + cl_index begin = length; for (;;) { c = ecl_getc_noeof(in); a = cat(rtbl, c); @@ -109,25 +156,42 @@ BEGIN: ecl_string_push_extend(cl_env.token, c); length++; } - goto NEXT; - } else if (islower(c)) - c = toupper(c); - else if (c == ':') { - if (colon_type == 0) { - colon_type = 1; - colon = length; - } else if (colon_type == 1 && colon == length-1) - colon_type = 2; - else - colon_type = -1; - /* Colon has appeared twice. */ + if (read_case == ecl_case_invert) { + escape_list = CONS(CONS(MAKE_FIXNUM(begin), + MAKE_FIXNUM(length-1)), + escape_list); + } + } else { + if (a == cat_whitespace || a == cat_terminating) { + ecl_ungetc(c, in); + break; + } + if (c == ':') { + if (colon_type == 0) { + colon_type = 1; + colon = length; + } else if (colon_type == 1 && colon == length-1) { + colon_type = 2; + } else { + colon_type = -1; + /* Colon has appeared twice. */ + } + } + if (read_case != ecl_case_preserve) { + if (isupper(c)) { + upcase++; + if (read_case == ecl_case_downcase) + c = tolower(c); + } else if (islower(c)) { + upcase++; + if (read_case == ecl_case_upcase) + c = toupper(c); + } + } + ecl_string_push_extend(cl_env.token, c); + length++; + count++; } - if (a == cat_whitespace || a == cat_terminating) { - ecl_ungetc(c, in); - break; - } - ecl_string_push_extend(cl_env.token, c); - length++; NEXT: c = ecl_getc(in); if (c == EOF) @@ -137,20 +201,35 @@ BEGIN: if (read_suppress) return(Cnil); - if (escape_flag || length == 0) + + /* If the readtable case was :INVERT and all non-escaped characters + * had the same case, we revert their case. */ + if (read_case == ecl_case_invert) { + if (upcase == count) { + invert_buffer_case(cl_env.token, escape_list, +1); + } else if (upcase == -count) { + invert_buffer_case(cl_env.token, escape_list, +1); + } + } + + /* If there are some escaped characters, it must be a symbol */ + if (length == 0 || (count < length)) goto SYMBOL; + + /* The case in which the buffer is full of dots has to be especial cased */ if (length == 1 && cl_env.token->string.self[0] == '.') { return @'si::.'; } else { for (i = 0; i < length; i++) if (cl_env.token->string.self[i] != '.') - goto N; + goto MAYBE_NUMBER; FEreader_error("Dots appeared illegally.", in, 0); } -N: +MAYBE_NUMBER: + /* Here we try to parse a number from the content of the buffer */ base = ecl_current_read_base(); - if (escape_flag || (base <= 10 && isalpha(cl_env.token->string.self[0]))) + if ((base <= 10) && isalpha(cl_env.token->string.self[0])) goto SYMBOL; x = parse_number(cl_env.token->string.self, cl_env.token->string.fillp, &i, base); if (x != OBJNULL && length == i) @@ -1164,6 +1243,7 @@ copy_readtable(cl_object from, cl_object to) struct ecl_readtable_entry *rtab; cl_index i; + /* Copy also the case for reading */ if (Null(to)) { to = cl_alloc_object(t_readtable); to->readtable.table = NULL; @@ -1178,8 +1258,11 @@ copy_readtable(cl_object from, cl_object to) rtab[i] = from->readtable.table[i]; */ /* structure assignment */ - } else - rtab=to->readtable.table; + } else { + rtab=to->readtable.table; + } + to->readtable.read_case = from->readtable.read_case; + for (i = 0; i < RTABSIZE; i++) if (from->readtable.table[i].dispatch_table != NULL) { rtab[i].dispatch_table @@ -1241,9 +1324,7 @@ ecl_current_read_default_float_format(void) FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.", 1, x); } - - static cl_object stream_or_default_input(cl_object stream) { @@ -1539,6 +1620,39 @@ CANNOT_PARSE: @(return copy_readtable(from, to)) @) +cl_object +cl_readtable_case(cl_object r) +{ + assert_type_readtable(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(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 { + FEwrong_type_argument(mode, cl_list(5, @'member', @':upcase', + @':downcase', @':preserve', + @':invert')); + } + @(return mode) +} + cl_object cl_readtablep(cl_object readtable) { @@ -1703,6 +1817,7 @@ init_read(void) int i; cl_core.standard_readtable = cl_alloc_object(t_readtable); + cl_core.standard_readtable->readtable.read_case = ecl_case_upcase; cl_core.standard_readtable->readtable.table = rtab = (struct ecl_readtable_entry *)cl_alloc(RTABSIZE * sizeof(struct ecl_readtable_entry)); diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index adae187f0..83fca6069 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -722,7 +722,7 @@ cl_symbols[] = { {"READ-SEQUENCE", CL_ORDINARY, cl_read_sequence, -1, OBJNULL}, {"READER-ERROR", CL_ORDINARY, NULL, -1, OBJNULL}, {"READTABLE", CL_ORDINARY, NULL, -1, OBJNULL}, -{"READTABLE-CASE", CL_ORDINARY, NULL, -1, OBJNULL}, +{"READTABLE-CASE", CL_ORDINARY, cl_readtable_case, 1, OBJNULL}, {"READTABLEP", CL_ORDINARY, cl_readtablep, 1, OBJNULL}, {"REAL", CL_ORDINARY, NULL, -1, OBJNULL}, {"REALP", CL_ORDINARY, cl_realp, 1, OBJNULL}, @@ -1137,6 +1137,7 @@ cl_symbols[] = { {SYS_ "PUT-PROPERTIES", SI_ORDINARY, si_put_properties, -1, OBJNULL}, {SYS_ "PUT-SYSPROP", SI_ORDINARY, si_put_sysprop, 3, OBJNULL}, {SYS_ "PUTPROP", SI_ORDINARY, si_putprop, 3, OBJNULL}, +{SYS_ "READTABLE-CASE-SET", SI_ORDINARY, si_readtable_case_set, 2, OBJNULL}, {SYS_ "REM-F", SI_ORDINARY, si_rem_f, 2, OBJNULL}, {SYS_ "REM-SYSPROP", SI_ORDINARY, si_rem_sysprop, 2, OBJNULL}, {SYS_ "REPLACE-ARRAY", SI_ORDINARY, si_replace_array, 2, OBJNULL}, @@ -1295,8 +1296,9 @@ cl_symbols[] = { {KEY_ "INHERITED", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "INITIAL-ELEMENT", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "INPUT", KEYWORD, NULL, -1, OBJNULL}, -{KEY_ "INTERNAL", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "INSTANCE", KEYWORD, NULL, -1, OBJNULL}, +{KEY_ "INTERNAL", KEYWORD, NULL, -1, OBJNULL}, +{KEY_ "INVERT", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "IO", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "JUNK-ALLOWED", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "KEY", KEYWORD, NULL, -1, OBJNULL}, @@ -1319,6 +1321,7 @@ cl_symbols[] = { {KEY_ "OVERWRITE", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "PACKAGE", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "PATHNAME", KEYWORD, NULL, -1, OBJNULL}, +{KEY_ "PRESERVE", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "PRETTY", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "PRINT", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "PROBE", KEYWORD, NULL, -1, OBJNULL}, diff --git a/src/h/external.h b/src/h/external.h index 0d9f1091a..e14d6033d 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -348,6 +348,7 @@ extern cl_object cl_name_char(cl_object s); extern cl_object cl_standard_char_p(cl_object c); extern cl_object cl_upper_case_p(cl_object c); +extern int ecl_string_case(cl_object s); extern cl_fixnum char_code(cl_object c); extern int digitp(int i, int r); extern bool char_eq(cl_object x, cl_object y); @@ -907,6 +908,7 @@ extern cl_object cl_logand _ARGS((cl_narg narg, ...)); extern cl_object cl_logeqv _ARGS((cl_narg narg, ...)); extern cl_object ecl_ash(cl_object x, cl_fixnum w); +extern int ecl_fixnum_bit_length(cl_fixnum l); /* num_pred.c */ @@ -1131,6 +1133,8 @@ extern cl_object cl_clear_input _ARGS((cl_narg narg, ...)); extern cl_object cl_parse_integer _ARGS((cl_narg narg, cl_object strng, ...)); extern cl_object cl_read_byte _ARGS((cl_narg narg, cl_object binary_input_stream, ...)); extern cl_object cl_copy_readtable _ARGS((cl_narg narg, ...)); +extern cl_object cl_readtable_case(cl_object r); +extern cl_object si_readtable_case_set(cl_object r, cl_object mode); extern cl_object cl_set_syntax_from_char _ARGS((cl_narg narg, cl_object tochr, cl_object fromchr, ...)); extern cl_object cl_set_macro_character _ARGS((cl_narg narg, cl_object chr, cl_object fnc, ...)); extern cl_object cl_get_macro_character _ARGS((cl_narg narg, cl_object chr, ...)); diff --git a/src/h/object.h b/src/h/object.h index ed151b6d4..15e58c5fc 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -341,8 +341,16 @@ struct ecl_readtable_entry { /* read table entry */ /* non-macro character */ }; +enum ecl_readtable_case { + ecl_case_upcase, + ecl_case_downcase, + ecl_case_invert, + ecl_case_preserve, +}; + struct ecl_readtable { /* read table */ HEADER; + enum ecl_readtable_case read_case; /* readtable-case */ struct ecl_readtable_entry *table; /* read table itself */ }; diff --git a/src/lsp/setf.lsp b/src/lsp/setf.lsp index 0f60fa91d..a6c8a06d6 100644 --- a/src/lsp/setf.lsp +++ b/src/lsp/setf.lsp @@ -203,6 +203,7 @@ Does not check if the third gang is a single-element list." (defsetf sys:instance-ref sys:instance-set) (defsetf compiler-macro-function (fname) (function) `(sys::put-sysprop ,fname 'sys::compiler-macro ,function)) +(defsetf readtable-case sys:readtable-case-set) (define-setf-expander getf (&environment env place indicator &optional default)