mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-04 00:11:37 -08:00
Code Issues Projects Releases Packages Wiki Activity

Fixed printer of bignums and implemented readtable case.

Browse source
This commit is contained in:
jjgarcia 2004-12-13 11:19:08 +00:00
parent 6691404feb
commit 4bfc19b3c3
10 changed files with 361 additions and 167 deletions
Download patch file Download diff file Expand all files Collapse all files

6
src/CHANGELOG
View file

@ -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 ***

20
src/c/character.d
View file

@ -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)))

6
src/c/num_log.d
View file

@ -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)

31
src/c/pathname.d
View file

@ -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.

266
src/c/print.d
View file

@ -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);

179
src/c/read.d
View file

@ -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));

7
src/c/symbols_list.h
View file

@ -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},

4
src/h/external.h
View file

@ -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, ...));

8
src/h/object.h
View file

@ -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 */
};

1
src/lsp/setf.lsp
View file

@ -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)