New function SI:COPY-TO-SIMPLE-BASE-STRING supersedes other redundant coercion functions. BASE_CHAR_P was wrong. Symbols can be made out of extended strings.

src/c/file.d

@@ -2495,7 +2495,7 @@ cl_get_output_stream_string(cl_object strm)
 	if (type_of(strm) != t_stream ||
 	    (enum ecl_smmode)strm->stream.mode != smm_string_output)
 		FEerror("~S is not a string-output stream.", 1, strm);
-	strng = copy_simple_base_string(strm->stream.object0);
+	strng = si_copy_to_simple_base_string(strm->stream.object0);
 	strm->stream.object0->base_string.fillp = 0;
 	@(return strng)
 }

src/c/package.d

@@ -285,7 +285,7 @@ intern(cl_object name, cl_object p, int *intern_flag)
 	cl_object s, ul;
 
 #ifdef ECL_UNICODE
-	name = coerce_to_simple_base_string(name);
+	name = si_copy_to_simple_base_string(name);
 #else
 	assert_type_base_string(name);
 #endif

src/c/pathname.d

@@ -39,12 +39,12 @@ typedef int (*delim_fn)(int);
 static cl_object
 ensure_simple_base_string(cl_object s)
 {
-	switch(type_of(s)) {
+	switch (type_of(s)) {
 #ifdef ECL_UNICODE
 	case t_string:
 #endif
 	case t_base_string:
-		return coerce_to_simple_base_string(s);
+		return si_copy_to_simple_base_string(s);
 	default:
 		return s;
 	}
@@ -86,7 +86,7 @@ destructively_check_directory(cl_object directory, bool logical)
 			if (i > 0)
 				return @':error';
 		} else if (type_of(item) == t_base_string) {
-			CAR(ptr) = copy_simple_base_string(item);
+			CAR(ptr) = si_copy_to_simple_base_string(item);
 			if (logical)
 				continue;
 			if (strcmp(item->base_string.self,".")==0) {
@@ -749,7 +749,11 @@ si_coerce_to_filename(cl_object pathname_orig)
 	pathname = coerce_to_file_pathname(pathname_orig);
 	if (cl_wild_pathname_p(1,pathname) != Cnil)
 		cl_error(3, @'file-error', @':pathname', pathname_orig);
-	namestring = coerce_to_simple_base_string(cl_namestring(pathname));
+	namestring = cl_namestring(pathname);
+	if (namestring == Cnil) {
+		FEerror("Pathname ~A does not have a physical namestring",
+			1, pathname_orig);
+	}
 	if (namestring->base_string.fillp >= MAXPATHLEN - 16)
 		FEerror("Too long filename: ~S.", 1, namestring);
 	return namestring;
@@ -1391,7 +1395,7 @@ copy_wildcards(cl_object *wilds_list, cl_object pattern)
 	}
 	/* Only create a new string when needed */
 	if (new_string)
-		pattern = copy_simple_base_string(cl_env.token);
+		pattern = si_copy_to_simple_base_string(cl_env.token);
 	*wilds_list = wilds;
 	return pattern;
 }

src/c/read.d

@@ -164,7 +164,7 @@ BEGIN:
 				   allow it, but later on in read_VV we make sure that
 				   all referenced packages have been properly built.
 				*/
-				cl_object name = copy_simple_base_string(cl_env.token);
+				cl_object name = si_copy_to_simple_base_string(cl_env.token);
 				if (cl_core.packages_to_be_created == OBJNULL) {
 					FEerror("There is no package with the name ~A.",
 						1, name);
@@ -290,7 +290,7 @@ SYMBOL:
 		x = ecl_find_symbol(cl_env.token, p, &intern_flag);
 		if (intern_flag != EXTERNAL) {
 			FEerror("Cannot find the external symbol ~A in ~S.",
-				2, copy_simple_base_string(cl_env.token), p);
+				2, si_copy_to_simple_base_string(cl_env.token), p);
 		}
 		return x;
 	}
@@ -586,7 +586,7 @@ static cl_object
 double_quote_reader(cl_object in, cl_object c)
 {
 	read_string(CHAR_CODE(c), in);
-	@(return copy_simple_base_string(cl_env.token))
+	@(return si_copy_to_simple_base_string(cl_env.token))
 }
 
 static cl_object
@@ -710,7 +710,7 @@ sharp_backslash_reader(cl_object in, cl_object c, cl_object d)
 		c = CODE_CHAR(strtoul(&c->base_string.self[1], NULL, 16));
 	} else {
 		cl_object nc = cl_name_char(c);
-		if (Null(nc)) FEreader_error("~S is an illegal character name.", in, 1, copy_simple_base_string(c));
+		if (Null(nc)) FEreader_error("~S is an illegal character name.", in, 1, si_copy_to_simple_base_string(c));
 		c = nc;
 	}
  OUTPUT:
@@ -1448,7 +1448,7 @@ do_read_delimited_list(int d, cl_object in, bool proper_list)
 #ifdef ECL_NEWLINE_IS_LFCR	/* From \n\r, ignore \r */
 	ecl_read_char(strm);
 #endif
-	@(return copy_simple_base_string(cl_env.token) (c == EOF? Ct : Cnil))
+	@(return si_copy_to_simple_base_string(cl_env.token) (c == EOF? Ct : Cnil))
 @)
 
 @(defun read-char (&optional (strm Cnil) (eof_errorp Ct) eof_value recursivep)

src/c/string.d

@@ -162,151 +162,53 @@ ecl_cstring_to_base_string_or_nil(const char *s)
 }
 
 
-/*
-	Copy_simple_base_string(x) copies string x to a simple base-string.
-*/
 cl_object
-copy_simple_base_string(cl_object x)
+si_copy_to_simple_base_string(cl_object x)
 {
 	cl_object y;
-	cl_index l = x->base_string.fillp;
-
-	y = cl_alloc_simple_base_string(l);
-	memcpy(y->base_string.self, x->base_string.self, l);
-	return(y);
-}
-
-#ifdef ECL_UNICODE
-cl_object
-copy_simple_string(cl_object x)
-{
-	cl_object y;
-	cl_index length = x->vector.fillp;
-
+ AGAIN:
 	switch(type_of(x)) {
-	case t_string:
-		y = cl_alloc_simple_extended_string(length);
-		memcpy(y->string.self, x->string.self, length * sizeof (cl_object));
-		return(y);
-	case t_base_string:
+	case t_symbol:
+		x = x->symbol.name;
+		goto AGAIN;
+	case t_character:
+		x = cl_string(x);
+		goto AGAIN;
+#ifdef ECL_UNICODE
+	case t_string: {
+		cl_index index, length = x->string.fillp;
+		y = cl_alloc_simple_base_string(length);
+		for (index=0; index < length; index++) {
+			cl_object c = x->string.self[index];
+			if (!BASE_CHAR_P(c))
+				FEerror("Cannot coerce string ~A to a base-string", 1, x);
+			y->base_string.self[index] = CHAR_CODE(c);
+		}
+		break;
+	}
+#endif
+	case t_base_string: {
+		cl_index length = x->base_string.fillp;
 		y = cl_alloc_simple_base_string(length);
 		memcpy(y->base_string.self, x->base_string.self, length);
-		return(y);
+		break;
 	}
-}
-#endif
-
-#ifdef ECL_UNICODE
-cl_object
-coerce_to_simple_base_string(cl_object source)
-{
-AGAIN:
-	switch(type_of(source)) {
-	case t_string: {
-		cl_index  index;
-		cl_index  length      = source->string.fillp;
-		cl_object destination = cl_alloc_simple_base_string(length);
-		for(index=0; index<length; index++) {
-			/* this will smash extended-chars arbitrarily ... checkme */
-			destination->base_string.self[index] = CHAR_CODE(source->string.self[index]);
-			}
-		return destination;
-		}
-	case t_base_string:
-		return source->base_string.adjustable? copy_simple_base_string(source) : source;
-	case t_symbol:
-		source = source->symbol.name;
-		goto AGAIN;
 	default:
-		FEtype_error_string(source);
+		/* This will signal a type error */
+		assert_type_string(x);
 	}
+	@(return y)
 }
 
-cl_object
-coerce_to_simple_extended_string(cl_object source)
-{
-AGAIN:
-	switch(type_of(source)) {
-	case t_string:
-		return source->string.adjustable? copy_simple_string(source) : source;
-	case t_base_string: {
-		cl_index  index;
-		cl_index  length      = source->string.fillp;
-		cl_object destination = cl_alloc_simple_extended_string(length);
-		for(index=0; index<length; index++) {
-			/* this will smash extended-chars arbitrarily ... checkme */
-			destination->string.self[index] = CODE_CHAR(source->base_string.self[index]);
-			}
-		return destination;
-		}
-	case t_symbol:
-		source = source->symbol.name;
-		goto AGAIN;
-	default:
-		FEtype_error_string(source);
-	}
-}
-
-cl_object
-coerce_to_simple_string(cl_object source)
-{
-AGAIN:
-	switch(type_of(source)) {
-	case t_string:
-		return source->base_string.adjustable? copy_simple_string(source) : source;
-	case t_base_string:
-		return source->base_string.adjustable? copy_simple_base_string(source) : source;
-	case t_symbol:
-		source = source->symbol.name;
-		goto AGAIN;
-	default:
-		FEtype_error_string(source);
-	}
-}
-#else
-cl_object
-coerce_to_simple_base_string(cl_object source)
-{
-AGAIN:
-	switch(type_of(source)) {
-	case t_base_string:
-		return source->base_string.adjustable? copy_simple_base_string(source) : source;
-	case t_symbol:
-		source = source->symbol.name;
-		goto AGAIN;
-	default:
-		FEtype_error_string(source);
-	}
-}
-
-cl_object
-coerce_to_simple_string(cl_object source)
-{
-AGAIN:
-	switch(type_of(source)) {
-	case t_string:
-		return source->base_string.adjustable? copy_simple_string(source) : source;
-	case t_base_string:
-		return source->base_string.adjustable? copy_simple_base_string(source) : source;
-	case t_symbol:
-		source = source->symbol.name;
-		goto AGAIN;
-	default:
-		FEtype_error_string(source);
-	}
-}
-#endif
-
 cl_object
 cl_string(cl_object x)
 {
-	cl_object y;
-
 	switch (type_of(x)) {
 	case t_symbol:
 		x = x->symbol.name;
 		break;
-	case t_character:
+	case t_character: {
+		cl_object y;
 #ifdef ECL_UNICODE
 		if (BASE_CHAR_P(x)) {
 			y = cl_alloc_simple_base_string(1);
@@ -323,6 +225,7 @@ cl_string(cl_object x)
 		x = y;
 		break;
 #endif
+	}
 #ifdef ECL_UNICODE
 	case t_string:
 #endif
@@ -338,40 +241,16 @@ cl_string(cl_object x)
 cl_object
 si_coerce_to_base_string(cl_object x)
 {
-	cl_object y;
-
-	switch (type_of(x)) {
-	case t_symbol:
-		x = x->symbol.name;
-		break;
-	case t_character:
-		/* truncates extended chars ... */
-		y = cl_alloc_simple_base_string(1);
-		y->base_string.self[0] = CHAR_CODE(x);
-		x = y;
-		break;
-	case t_string: {
-		cl_index index;
-		y = cl_alloc_simple_base_string(x->string.fillp);
-		for(index=0; index<x->string.fillp; index++)
-			y->base_string.self[index] = CHAR_CODE(x->string.self[index]);
-		x = y;
-		}
-	case t_base_string:
-		break;
-	default:
-		FEtype_error_string(x);
+	if (type_of(x) != t_base_string) {
+		x = si_copy_to_simple_base_string(x);
 	}
 	@(return x)
 }
-#endif
 
-#ifdef ECL_UNICODE
 cl_object
 si_coerce_to_extended_string(cl_object x)
 {
 	cl_object y;
-
 AGAIN:
 	switch (type_of(x)) {
 	case t_symbol:
@@ -380,21 +259,22 @@ AGAIN:
 	case t_character:
 		y = cl_alloc_simple_extended_string(1);
 		y->string.self[0] = x;
-		x = y;
 		break;
 	case t_base_string: {
-		cl_index index;
+		cl_index index, len = x->base_string.dim;
 		y = cl_alloc_simple_extended_string(x->base_string.fillp);
-		for(index=0; index<x->base_string.fillp; index++)
+		for(index=0; index < len; index++) {
 			y->string.self[index] = CODE_CHAR(x->base_string.self[index]);
-		x = y;
 		}
+		y->string.fillp = x->base_string.fillp;
+	}
 	case t_string:
+		y = x;
 		break;
 	default:
 		FEtype_error_string(x);
 	}
-	@(return x)
+	@(return y)
 }
 #endif
 
@@ -1230,7 +1110,7 @@ string_case(cl_narg narg, int (*casefun)(int c, bool *bp), cl_va_list ARGS)
 	cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE);
 
 	strng = cl_string(strng);
-	conv  = copy_simple_string(strng);
+	conv  = cl_copy_seq(strng);
 	if (startp == Cnil)
 		start = MAKE_FIXNUM(0);
 	get_string_start_end(conv, start, end, &s, &e);

src/c/symbol.d

@@ -23,7 +23,7 @@ static void FEtype_error_plist(cl_object x) /*__attribute__((noreturn))*/;
 cl_object
 cl_make_symbol(cl_object str)
 {
-	assert_type_base_string(str);
+	str = si_copy_to_simple_base_string(str);
 	@(return make_symbol(str))
 }
 
@@ -34,7 +34,7 @@ make_symbol(cl_object st)
 
 	x = cl_alloc_object(t_symbol);
 	/* FIXME! Should we copy? */
-	x->symbol.name = copy_simple_base_string(st);
+	x->symbol.name = si_copy_to_simple_base_string(st);
 	x->symbol.dynamic = 0;
 	ECL_SET(x,OBJNULL);
 	SYM_FUN(x) = Cnil;

src/c/symbols_list.h

@@ -1082,7 +1082,7 @@ cl_symbols[] = {
 {SYS_ "COERCE-TO-FILENAME", SI_ORDINARY, si_coerce_to_filename, 1, OBJNULL},
 {SYS_ "COERCE-TO-FUNCTION", SI_ORDINARY, si_coerce_to_function, 1, OBJNULL},
 {SYS_ "COERCE-TO-PACKAGE", SI_ORDINARY, si_coerce_to_package, 1, OBJNULL},
-{SYS_ "COERCE-TO-SIMPLE-BASE-STRING", SI_ORDINARY, coerce_to_simple_base_string, 1, OBJNULL},
+{SYS_ "COPY-TO-SIMPLE-BASE-STRING", SI_ORDINARY, si_copy_to_simple_base_string, 1, OBJNULL},
 {SYS_ "COMPILED-FUNCTION-BLOCK", SI_ORDINARY, si_compiled_function_block, 1, OBJNULL},
 {SYS_ "COMPILED-FUNCTION-NAME", SI_ORDINARY, si_compiled_function_name, 1, OBJNULL},
 {SYS_ "COPY-STREAM", SI_ORDINARY, si_copy_stream, 1, OBJNULL},

src/c/symbols_list2.h

@@ -1082,7 +1082,7 @@ cl_symbols[] = {
 {SYS_ "COERCE-TO-FILENAME","si_coerce_to_filename"},
 {SYS_ "COERCE-TO-FUNCTION","si_coerce_to_function"},
 {SYS_ "COERCE-TO-PACKAGE","si_coerce_to_package"},
-{SYS_ "COERCE-TO-SIMPLE-BASE-STRING","coerce_to_simple_base_string"},
+{SYS_ "COPY-TO-SIMPLE-BASE-STRING","si_copy_to_simple_base_string"},
 {SYS_ "COMPILED-FUNCTION-BLOCK","si_compiled_function_block"},
 {SYS_ "COMPILED-FUNCTION-NAME","si_compiled_function_name"},
 {SYS_ "COPY-STREAM","si_copy_stream"},

src/c/tcp.d

@@ -268,7 +268,7 @@ si_open_client_stream(cl_object host, cl_object port)
    cl_object stream;
 
    /* Ensure "host" is a string that we can pass to a C function */
-   host = coerce_to_simple_base_string(host);
+   host = si_copy_to_simple_base_string(host);
 
    /* The port number is not negative */
    p = fixnnint(port);
@@ -365,7 +365,7 @@ si_lookup_host_entry(cl_object host_or_address)
 
 	switch (type_of(host_or_address)) {
 	case t_base_string:
-		host_or_address = coerce_to_simple_base_string(host_or_address);
+		host_or_address = si_copy_to_simple_base_string(host_or_address);
 		he = gethostbyname(host_or_address->base_string.self);
 		break;
 	case t_fixnum:

src/c/unixfsys.d

@@ -390,7 +390,7 @@ homedir_pathname(cl_object user)
 		char *p;
 		/* This ensures that our string has the right length
 		   and it is terminated with a '\0' */
-		user = coerce_to_simple_base_string(cl_string(user));
+		user = si_copy_to_simple_base_string(user);
 		p = user->base_string.self;
 		i = user->base_string.fillp;
 		if (i > 0 && *p == '~') {

src/c/unixsys.d

@@ -29,12 +29,10 @@
 #endif
 
 cl_object
-si_system(cl_object cmd)
+si_system(cl_object cmd_string)
 {
-	volatile int code;
-
-	cmd = coerce_to_simple_base_string(cmd);
-	code = system((const char *)(cmd->base_string.self));
+	cl_object cmd = si_copy_to_simple_base_string(cmd_string);
+	int code = system((const char *)(cmd->base_string.self));
 	/* FIXME! Are there any limits for system()? */
 	/* if (cmd->base_string.fillp >= 1024)
 		FEerror("Too long command line: ~S.", 1, cmd);*/
@@ -49,15 +47,14 @@ si_getpid(void)
 }
 
 cl_object
-si_open_pipe(cl_object cmd)
+si_open_pipe(cl_object cmd_string)
 {
 #ifdef _MSC_VER
 	FEerror("Pipes are not supported under Win32/MSVC", 0);
 #else
 	FILE *ptr;
 	cl_object stream;
-
-	cmd = coerce_to_simple_base_string(cmd);
+	cl_object cmd = si_copy_to_simple_base_string(cmd);
 	ptr = popen(cmd->base_string.self, "r");
 	if (ptr == NULL)
 		@(return Cnil);
@@ -128,8 +125,8 @@ stream_to_handle(cl_object s, bool output)
 	cl_object stream_write;
 	cl_object stream_read;
 @{
-	command = coerce_to_simple_base_string(command);
-	argv = cl_mapcar(2, @'si::coerce-to-simple-base-string', argv);
+	command = si_copy_to_simple_base_string(command);
+	argv = cl_mapcar(2, @'si::copy-to-simple-base-string', argv);
 #if defined(mingw32) || defined (_MSC_VER)
 {
 	BOOL ok;

src/h/external.h

@@ -1265,6 +1265,7 @@ extern cl_object cl_nstring_upcase _ARGS((cl_narg narg, ...));
 extern cl_object cl_nstring_downcase _ARGS((cl_narg narg, ...));
 extern cl_object cl_nstring_capitalize _ARGS((cl_narg narg, ...));
 extern cl_object si_base_string_concatenate _ARGS((cl_narg narg, ...));
+extern cl_object si_copy_to_simple_base_string(cl_object s);
 
 extern cl_object cl_alloc_simple_base_string(cl_index l);
 extern cl_object cl_alloc_adjustable_base_string(cl_index l);
@@ -1272,9 +1273,6 @@ extern cl_object make_simple_base_string(char *s);
 #define make_constant_base_string(s) (make_simple_base_string((char *)s))
 extern cl_object make_base_string_copy(const char *s);
 extern cl_object ecl_cstring_to_base_string_or_nil(const char *s);
-extern cl_object copy_simple_base_string(cl_object x);
-extern cl_object coerce_to_simple_string(cl_object x);
-extern cl_object coerce_to_simple_base_string(cl_object x);
 extern bool string_eq(cl_object x, cl_object y);
 extern bool string_equal(cl_object x, cl_object y);
 extern bool member_char(int c, cl_object char_bag);
@@ -1458,7 +1456,6 @@ extern cl_object si_coerce_to_base_string(cl_object x);
 extern cl_object si_coerce_to_extended_string(cl_object x);
 extern cl_object si_extended_string_concatenate _ARGS((cl_narg narg, ...));
 extern cl_object cl_alloc_simple_extended_string(cl_index l);
-extern cl_object coerce_to_simple_extended_string(cl_object x);
 #else
 #define si_base_char_p cl_characterp
 #define si_base_string_p cl_stringp

src/h/object.h

@@ -64,7 +64,7 @@ typedef cl_object (*cl_objectfn_fixed)();
 #define CHARACTER_TAG		2
 #define CHARACTERP(obje)	(((cl_fixnum)(obje)) & 2)
 #ifdef ECL_UNICODE
-#define BASE_CHAR_P(obje)	((((cl_fixnum)(obje)) & 0xFFFFFD02) == 2)
+#define BASE_CHAR_P(obje)	((((cl_fixnum)(obje)) & 0xFFFFFC03) == 2)
 #define	CODE_CHAR(c)		((cl_object)(((cl_fixnum)(c << 2)|CHARACTER_TAG)))
 #define	CHAR_CODE(obje)		(((cl_fixnum)(obje)) >> 2)
 #else