diff --git a/msvc/ecl-threads.def b/msvc/ecl-threads.def index 571b37b8f..1441484e5 100755 --- a/msvc/ecl-threads.def +++ b/msvc/ecl-threads.def @@ -997,7 +997,7 @@ EXPORTS member_char ecl_string_push_extend get_string_start_end - + ecl_fits_in_base_string ; structure.c @@ -1037,7 +1037,6 @@ EXPORTS ;cl_defvar ;cl_defparameter - make_symbol make_keyword symbol_value ecl_getf diff --git a/msvc/ecl.def b/msvc/ecl.def index a97dda626..2beb65bec 100644 --- a/msvc/ecl.def +++ b/msvc/ecl.def @@ -1003,7 +1003,7 @@ EXPORTS member_char ecl_string_push_extend get_string_start_end - + ecl_fits_in_base_string ; structure.c @@ -1043,7 +1043,6 @@ EXPORTS ;cl_defvar ;cl_defparameter - make_symbol make_keyword symbol_value ecl_getf diff --git a/src/CHANGELOG b/src/CHANGELOG index b7f5c4f62..c53c2139a 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -115,6 +115,8 @@ ECL 1.0: - The FFI will signal a type error when converting extended characters to the C types "char" or "unsigned char". + - EQUAL did not work with extended strings. + * Other visible changes: - EXT:PROCESS-COMMAND-ARGS now allows for a default rule. @@ -158,7 +160,7 @@ ECL 1.0: - C functions which disappear: si_set_compiled_function_name(), si_extended_string_concatenate(), assert_type_string(), - assert_type_character(), assert_type_symbol(). + assert_type_character(), assert_type_symbol(), make_symbol(). - Lisp functions which disappear: si:set-compiled-function-name, si:extended-string-concatenate, si:list-nth, si:rplaca-nthcdr. diff --git a/src/c/package.d b/src/c/package.d index da818d9b3..d12f88020 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -294,8 +294,12 @@ intern(cl_object name, cl_object p, int *intern_flag) { cl_object s, ul; - /* FIXME! Symbols restricted to base string */ - name = ecl_check_cl_type(@'intern', name, t_base_string); + name = ecl_check_type_string(@'intern', name); +#ifdef ECL_UNICODE + if (ecl_fits_in_base_string(name)) { + name = si_copy_to_simple_base_string(name); + } +#endif p = si_coerce_to_package(p); TRY_AGAIN_LABEL: PACKAGE_LOCK(p); @@ -325,7 +329,7 @@ intern(cl_object name, cl_object p, int *intern_flag) "Ignore lock and proceed", p, 2, name, p); goto TRY_AGAIN_LABEL; } - s = make_symbol(name); + s = cl_make_symbol(name); s->symbol.hpack = p; *intern_flag = 0; if (p == cl_core.keyword_package) { @@ -349,8 +353,12 @@ ecl_find_symbol_nolock(cl_object name, cl_object p, int *intern_flag) { cl_object s, ul; - /* FIXME! Symbols restricted to base string */ - name = ecl_check_cl_type(@'find-symbol', name, t_base_string); + name = ecl_check_type_string(@'find-symbol', name); +#ifdef ECL_UNICODE + if (ecl_fits_in_base_string(name)) { + name = si_copy_to_simple_base_string(name); + } +#endif s = gethash_safe(name, p->pack.external, OBJNULL); if (s != OBJNULL) { *intern_flag = EXTERNAL; @@ -662,7 +670,7 @@ shadow(cl_object s, cl_object p) PACKAGE_LOCK(p); x = ecl_find_symbol_nolock(s, p, &intern_flag); if (intern_flag != INTERNAL && intern_flag != EXTERNAL) { - x = make_symbol(s); + x = cl_make_symbol(s); sethash(x->symbol.name, p->pack.internal, x); x->symbol.hpack = p; } diff --git a/src/c/predicate.d b/src/c/predicate.d index dfdc0d58a..fa0350276 100644 --- a/src/c/predicate.d +++ b/src/c/predicate.d @@ -255,48 +255,37 @@ bool eql(cl_object x, cl_object y) { cl_type t; - if (x == y) return(TRUE); if ((t = type_of(x)) != type_of(y)) return(FALSE); switch (t) { - case t_fixnum: - return(fix(x) == fix(y)); - + return FALSE; case t_bignum: - return(big_compare(x, y) == 0); - + return (big_compare(x, y) == 0); case t_ratio: - return(eql(x->ratio.num, y->ratio.num) && - eql(x->ratio.den, y->ratio.den)); - + return (eql(x->ratio.num, y->ratio.num) && + eql(x->ratio.den, y->ratio.den)); #ifdef ECL_SHORT_FLOAT case t_shortfloat: return ecl_short_float(x) == ecl_short_float(y); #endif case t_singlefloat: - return(sf(x) == sf(y)); - + return (sf(x) == sf(y)); case t_doublefloat: - return(df(x) == df(y)); + return (df(x) == df(y)); #ifdef ECL_LONG_FLOAT case t_longfloat: return ecl_long_float(x) == ecl_long_float(y); #endif case t_complex: - if (eql(x->complex.real, y->complex.real) && - eql(x->complex.imag, y->complex.imag)) - return(TRUE); - else - return(FALSE); - + return (eql(x->complex.real, y->complex.real) && + eql(x->complex.imag, y->complex.imag)); case t_character: return(CHAR_CODE(x) == CHAR_CODE(y)); - default: - return(FALSE); + return FALSE; } } @@ -309,51 +298,61 @@ cl_eql(cl_object x, cl_object y) bool equal(register cl_object x, cl_object y) { - register cl_type t; - + cl_type tx, ty; BEGIN: - if ((t = type_of(x)) != type_of(y)) - return(FALSE); if (x==y) return(TRUE); - switch (t) { - + tx = type_of(x); + ty = type_of(y); + switch (tx) { case t_cons: - if (!equal(CAR(x), CAR(y))) - return(FALSE); + if (tx != ty || !equal(CAR(x), CAR(y))) + return FALSE; x = CDR(x); y = CDR(y); goto BEGIN; - case t_symbol: case t_vector: case t_array: - return FALSE; - case t_fixnum: - return(fix(x)==fix(y)); + return FALSE; + case t_bignum: + return (tx == ty) && (big_compare(x,y) == 0); + case t_ratio: + return (tx == ty) && eql(x->ratio.num, y->ratio.num) && + eql(x->ratio.den, y->ratio.den); #ifdef ECL_SHORT_FLOAT case t_shortfloat: - return ecl_short_float(x) == ecl_short_float(y); + return (tx == ty) && (ecl_short_float(x) == ecl_short_float(y)); #endif case t_singlefloat: - return(sf(x)==sf(y)); + return (tx == ty) && (sf(x)==sf(y)); case t_doublefloat: - return(df(x)==df(y)); + return (tx == ty) && (df(x)==df(y)); #ifdef ECL_LONG_FLOAT case t_longfloat: - return ecl_long_float(x) == ecl_long_float(y); + return (tx == ty) && (ecl_long_float(x) == ecl_long_float(y)); #endif + case t_complex: + return (tx = ty) && eql(x->complex.real, y->complex.real) && + eql(x->complex.imag, y->complex.imag); + case t_character: + return(CHAR_CODE(x) == CHAR_CODE(y)); + case t_base_string: #ifdef ECL_UNICODE case t_string: + if (ty != t_base_string && ty != t_string) + return FALSE; +#else + if (ty != t_base_string) + return FALSE; #endif - case t_base_string: - return(string_eq(x, y)); - + return string_eq(x, y); case t_bitvector: { cl_index i, ox, oy; - + if (ty != tx) + return FALSE; if (x->vector.fillp != y->vector.fillp) return(FALSE); ox = x->vector.offset; @@ -364,43 +363,6 @@ BEGIN: return(FALSE); return(TRUE); } - -#ifdef CLOS - case t_instance: { - cl_index i, l = x->instance.length; - - if (CLASS_OF(x) != CLASS_OF(y)) - return(FALSE); - if (l != y->instance.length) - return(FALSE); - for (i = 0; i < l; i++) { - cl_object vx = x->instance.slots[i]; - cl_object vy = y->instance.slots[i]; - if (vx == OBJNULL) { - if (vy != OBJNULL) - return FALSE; - } else if (vy == OBJNULL) { - return FALSE; - } else if (!equal(vx, vy)) { - return FALSE; - } - } - return TRUE; - } -#else - case t_structure: - { - int i; - - if (x->str.name != y->str.name) - return(FALSE); - for (i = 0; i < x->str.length; i++) - if (!equal(x->str.self[i], y->str.self[i])) - return(FALSE); - return(TRUE); - } -#endif /* CLOS */ - case t_pathname: return(equal(x->pathname.host, y->pathname.host) && equal(x->pathname.device, y->pathname.device) && @@ -408,12 +370,10 @@ BEGIN: equal(x->pathname.name, y->pathname.name) && equal(x->pathname.type, y->pathname.type) && equal(x->pathname.version, y->pathname.version)); - case t_foreign: - return (x->foreign.data == y->foreign.data); - + return (tx == ty) && (x->foreign.data == y->foreign.data); default: - return(eql(x,y)); + return FALSE; } } diff --git a/src/c/read.d b/src/c/read.d index 2875f3782..b5df6095a 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -338,7 +338,7 @@ BEGIN: if (p == Cnil) { p = current_package(); } - /* INV: make_symbol() copies the string */ + /* INV: cl_make_symbol() copies the string */ x = intern(token, p, &intern_flag); } OUTPUT: @@ -993,7 +993,7 @@ M: if (read_suppress) { output = Cnil; } else { - output = make_symbol(token); + output = cl_make_symbol(token); } si_put_buffer_string(token); @(return output) diff --git a/src/c/string.d b/src/c/string.d index eb2d7593c..08f5769b8 100644 --- a/src/c/string.d +++ b/src/c/string.d @@ -156,6 +156,28 @@ ecl_cstring_to_base_string_or_nil(const char *s) return make_base_string_copy(s); } +bool +ecl_fits_in_base_string(cl_object s) +{ + AGAIN: + switch (type_of(s)) { +#ifdef ECL_UNICODE + case t_string: { + cl_index i; + for (i = 0; i < s->string.fillp; i++) { + if (!BASE_CHAR_P(s->string.self[i])) + return 0; + } + return 1; + } +#endif + case t_base_string: + return 1; + default: + s = ecl_type_error(@'si::copy-to-simple-base-string',"",s,@'string'); + goto AGAIN; + } +} cl_object si_copy_to_simple_base_string(cl_object x) @@ -535,10 +557,8 @@ string_eq(cl_object x, cl_object y) break; case t_base_string: switch(type_of(y)) { - case t_string: { - cl_object z = x; x = y; y = z; - goto AGAIN; - } + case t_string: + return string_eq(y, x); case t_base_string: return memcmp(x->base_string.self, y->base_string.self, i) == 0; default: diff --git a/src/c/symbol.d b/src/c/symbol.d index 093dfd45d..8e23b1c5a 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -23,20 +23,28 @@ static void FEtype_error_plist(cl_object x) /*__attribute__((noreturn))*/; cl_object cl_make_symbol(cl_object str) -{ - str = ecl_check_type_string(@'make-symbol',str); - str = si_copy_to_simple_base_string(str); - @(return make_symbol(str)) -} - -cl_object -make_symbol(cl_object st) { cl_object x; - + AGAIN: + /* INV: In several places it is assumed that we copy the string! */ + switch (type_of(str)) { +#ifdef ECL_UNICODE + case t_string: + if (!ecl_fits_in_base_string(str)) { + str = cl_copy_seq(str); + } else { + str = si_copy_to_simple_base_string(str); + } +#endif + case t_base_string: + str = si_copy_to_simple_base_string(str); + break; + default: + str = ecl_type_error(@'make-symbol',"name",str,@'string'); + goto AGAIN; + } x = cl_alloc_object(t_symbol); - /* FIXME! Should we copy? */ - x->symbol.name = si_copy_to_simple_base_string(st); + x->symbol.name = str; x->symbol.dynamic = 0; ECL_SET(x,OBJNULL); SYM_FUN(x) = Cnil; @@ -45,7 +53,7 @@ make_symbol(cl_object st) x->symbol.stype = stp_ordinary; x->symbol.mflag = FALSE; x->symbol.isform = FALSE; - return(x); + @(return x) } /* @@ -232,7 +240,7 @@ cl_symbol_name(cl_object x) @(defun copy_symbol (sym &optional cp &aux x) @ x = ecl_check_cl_type(@'copy-symbol', x, t_symbol); - x = make_symbol(sym->symbol.name); + x = cl_make_symbol(sym->symbol.name); if (Null(cp)) @(return x) x->symbol.stype = sym->symbol.stype; @@ -249,20 +257,19 @@ cl_symbol_name(cl_object x) cl_type t; cl_object counter, output; bool increment; -@ +@ { + AGAIN: if (ecl_stringp(prefix)) { counter = SYM_VAL(@'*gensym-counter*'); increment = 1; + } else if ((t = type_of(prefix)) == t_fixnum || t == t_bignum) { + counter = prefix; + prefix = cl_core.gensym_prefix; + increment = 0; } else { - cl_type t = type_f(t); - if (t == t_fixnum || t == t_bignum) { - counter = prefix; - prefix = cl_core.gensym_prefix; - increment = 0; - } else { - FEwrong_type_argument(cl_list(3, @'or', @'string', @'integer'), - prefix); - } + prefix = ecl_type_error(@'gensym',"prefix",prefix, + cl_list(3, @'or', @'string', @'integer')); + goto AGAIN; } output = ecl_make_string_output_stream(64); bds_bind(@'*print-base*', MAKE_FIXNUM(10)); @@ -270,18 +277,17 @@ cl_symbol_name(cl_object x) princ(prefix, output); princ(counter, output); bds_unwind_n(2); - output = make_symbol(cl_get_output_stream_string(output)); + output = cl_make_symbol(cl_get_output_stream_string(output)); if (increment) ECL_SETQ(@'*gensym-counter*',one_plus(counter)); - @(return output) -@) + @(return output); +} @) @(defun gentemp (&optional (prefix cl_core.gentemp_prefix) (pack current_package())) cl_object output, s; int intern_flag; @ - /* FIXME! Symbols restricted to base string */ - prefix = ecl_check_cl_type(@'gentemp', prefix, t_base_string); + prefix = ecl_check_type_string(@'gentemp', prefix); pack = si_coerce_to_package(pack); ONCE_MORE: output = ecl_make_string_output_stream(64); diff --git a/src/h/external.h b/src/h/external.h index 4bfd5dd79..da0e4216a 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -1306,7 +1306,7 @@ extern bool string_eq(cl_object x, cl_object y); extern bool member_char(int c, cl_object char_bag); extern int ecl_string_push_extend(cl_object s, int c); extern void get_string_start_end(cl_object s, cl_object start, cl_object end, cl_index *ps, cl_index *pe); - +extern bool ecl_fits_in_base_string(cl_object s); /* structure.c */ @@ -1349,7 +1349,6 @@ extern cl_object si_put_properties _ARGS((cl_narg narg, cl_object sym, ...)); extern void cl_defvar(cl_object s, cl_object v); extern void cl_defparameter(cl_object s, cl_object v); -extern cl_object make_symbol(cl_object st); extern cl_object make_keyword(const char *s); extern cl_object symbol_value(cl_object s); extern cl_object ecl_getf(cl_object place, cl_object indicator, cl_object deflt);