Allow creating symbols with extended characters in the name, and teach EQUAL how to compare strings with different character types.

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

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

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.

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;
 	}

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;
 	}
 }
 

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)

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:

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

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