diff --git a/src/c/file.d b/src/c/file.d index d486343ee..f38b50812 100644 --- a/src/c/file.d +++ b/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) } diff --git a/src/c/package.d b/src/c/package.d index b813d769f..aca78a465 100644 --- a/src/c/package.d +++ b/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 diff --git a/src/c/pathname.d b/src/c/pathname.d index e753743c8..1401290d8 100644 --- a/src/c/pathname.d +++ b/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; } diff --git a/src/c/read.d b/src/c/read.d index 3e7e82a25..a6b196a80 100644 --- a/src/c/read.d +++ b/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) diff --git a/src/c/string.d b/src/c/string.d index c1c89633e..108b5af59 100644 --- a/src/c/string.d +++ b/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; indexbase_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; indexstring.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; indexstring.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; indexbase_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); diff --git a/src/c/symbol.d b/src/c/symbol.d index 2f5da2de1..98b26d4ca 100644 --- a/src/c/symbol.d +++ b/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; diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 0d8b1c77b..5896a2f2f 100644 --- a/src/c/symbols_list.h +++ b/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}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index a6f430cc4..5b59456fa 100644 --- a/src/c/symbols_list2.h +++ b/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"}, diff --git a/src/c/tcp.d b/src/c/tcp.d index 6bd4cd8e7..eb496f609 100644 --- a/src/c/tcp.d +++ b/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: diff --git a/src/c/unixfsys.d b/src/c/unixfsys.d index 2ed8665fd..0040b693e 100644 --- a/src/c/unixfsys.d +++ b/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 == '~') { diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 33d051a90..e82e0727b 100644 --- a/src/c/unixsys.d +++ b/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; diff --git a/src/h/external.h b/src/h/external.h index f7751d69c..001ef15d7 100644 --- a/src/h/external.h +++ b/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 diff --git a/src/h/object.h b/src/h/object.h index e3af57532..9652b6487 100644 --- a/src/h/object.h +++ b/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