Commit 6982a805 authored by Daniel Kochmański's avatar Daniel Kochmański

Merge branch 'cleanup-string-building' into 'develop'

clean up functions creating base strings from C strings

Closes #462

See merge request !131
parents 2b782276 24dcb778
Pipeline #42462244 (#198) passed with stage
......@@ -96,17 +96,17 @@ mangle_name(cl_object output, unsigned char *source, int l)
if (is_symbol) {
cl_fixnum p;
if (symbol == ECL_NIL) {
@(return ECL_T make_constant_base_string("ECL_NIL"));
@(return ECL_T ecl_make_constant_base_string("ECL_NIL",-1));
}
else if (symbol == ECL_T) {
@(return ECL_T make_constant_base_string("ECL_T"));
@(return ECL_T ecl_make_constant_base_string("ECL_T",-1));
}
p = (cl_symbol_initializer*)symbol - cl_symbols;
if (p >= 0 && p <= cl_num_symbols_in_core) {
found = ECL_T;
output = cl_format(4, ECL_NIL,
make_constant_base_string("ECL_SYM(~S,~D)"),
ecl_make_constant_base_string("ECL_SYM(~S,~D)",-1),
name, ecl_make_fixnum(p));
@(return found output maxarg);
}
......@@ -133,11 +133,11 @@ mangle_name(cl_object output, unsigned char *source, int l)
;
}
else if (package == cl_core.lisp_package)
package = make_constant_base_string("cl");
package = ecl_make_constant_base_string("cl",-1);
else if (package == cl_core.system_package)
package = make_constant_base_string("si");
package = ecl_make_constant_base_string("si",-1);
else if (package == cl_core.ext_package)
package = make_constant_base_string("si");
package = ecl_make_constant_base_string("si",-1);
else if (package == cl_core.keyword_package)
package = ECL_NIL;
else
......@@ -216,7 +216,7 @@ make_this_symbol(int i, cl_object s, int code, const char *name,
s->symbol.hpack = ECL_NIL;
s->symbol.stype = stp;
s->symbol.hpack = package;
s->symbol.name = make_constant_base_string(name);
s->symbol.name = ecl_make_constant_base_string(name,-1);
if (package == cl_core.keyword_package) {
package->pack.external =
_ecl_sethash(s->symbol.name, package->pack.external, s);
......
......@@ -161,7 +161,7 @@ out_of_memory(size_t requested_bytes)
switch (method) {
case 0: cl_error(1, @'ext::storage-exhausted');
break;
case 1: cl_cerror(2, make_constant_base_string("Extend heap size"),
case 1: cl_cerror(2, ecl_make_constant_base_string("Extend heap size",-1),
@'ext::storage-exhausted');
break;
case 2:
......
......@@ -507,7 +507,7 @@ cl_char_name(cl_object c)
start = name;
}
start[0] = 'U';
output = make_base_string_copy((const char*)start);
output = ecl_make_simple_base_string((const char*)start,-1);
}
@(return output);
}
......
......@@ -174,7 +174,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) {
cl_object line_no;
if (cl_fboundp(@'si::formatter-aux') != ECL_NIL)
line_format = make_constant_base_string("~%~4d\t");
line_format = ecl_make_constant_base_string("~%~4d\t",-1);
else
line_format = ECL_NIL;
BEGIN:
......
......@@ -133,7 +133,7 @@ FEerror(const char *s, int narg, ...)
ecl_va_end(args);
funcall(4, @'si::universal-error-handler',
ECL_NIL, /* not correctable */
make_constant_base_string(s), /* condition text */
ecl_make_constant_base_string(s,-1), /* condition text */
rest);
_ecl_unexpected_return();
}
......@@ -146,7 +146,7 @@ CEerror(cl_object c, const char *err, int narg, ...)
ecl_enable_interrupts();
return funcall(4, @'si::universal-error-handler',
c, /* correctable */
make_constant_base_string(err), /* continue-format-string */
ecl_make_constant_base_string(err,-1), /* continue-format-string */
cl_grab_rest_args(args));
}
......@@ -160,7 +160,7 @@ FEprogram_error(const char *s, int narg, ...)
cl_object real_args, text;
ecl_va_list args;
ecl_va_start(args, narg, narg, 0);
text = make_constant_base_string(s);
text = ecl_make_constant_base_string(s,-1);
real_args = cl_grab_rest_args(args);
if (cl_boundp(@'si::*current-form*') != ECL_NIL) {
/* When FEprogram_error is invoked from the compiler, we can
......@@ -169,7 +169,7 @@ FEprogram_error(const char *s, int narg, ...)
cl_object stmt = ecl_symbol_value(@'si::*current-form*');
if (stmt != ECL_NIL) {
real_args = @list(3, stmt, text, real_args);
text = make_constant_base_string("In form~%~S~%~?");
text = ecl_make_constant_base_string("In form~%~S~%~?",-1);
}
}
si_signal_simple_error(4,
......@@ -188,7 +188,7 @@ FEcontrol_error(const char *s, int narg, ...)
si_signal_simple_error(4,
@'control-error', /* condition name */
ECL_NIL, /* not correctable */
make_constant_base_string(s), /* format control */
ecl_make_constant_base_string(s,-1), /* format control */
cl_grab_rest_args(args)); /* format args */
_ecl_unexpected_return();
}
......@@ -196,7 +196,7 @@ FEcontrol_error(const char *s, int narg, ...)
void
FEreader_error(const char *s, cl_object stream, int narg, ...)
{
cl_object message = make_constant_base_string(s);
cl_object message = ecl_make_constant_base_string(s,-1);
cl_object args_list;
ecl_va_list args;
ecl_va_start(args, narg, narg, 0);
......@@ -210,8 +210,8 @@ FEreader_error(const char *s, cl_object stream, int narg, ...)
args_list);
} else {
/* Actual reader error */
cl_object prefix = make_constant_base_string("Reader error in file ~S, "
"position ~D:~%");
cl_object prefix = ecl_make_constant_base_string("Reader error in file ~S, "
"position ~D:~%",-1);
cl_object position = cl_file_position(1, stream);
message = si_base_string_concatenate(2, prefix, message);
args_list = cl_listX(3, stream, position, args_list);
......@@ -274,7 +274,7 @@ FEwrong_type_only_arg(cl_object function, cl_object value, cl_object type)
si_signal_simple_error(8,
@'type-error', /* condition name */
ECL_NIL, /* not correctable */
make_constant_base_string(message), /* format control */
ecl_make_constant_base_string(message,-1), /* format control */
cl_list(3, function, value, type),
@':expected-type', type,
@':datum', value);
......@@ -298,7 +298,7 @@ FEwrong_type_nth_arg(cl_object function, cl_narg narg, cl_object value, cl_objec
si_signal_simple_error(8,
@'type-error', /* condition name */
ECL_NIL, /* not correctable */
make_constant_base_string(message), /* format control */
ecl_make_constant_base_string(message,-1), /* format control */
cl_list(4, function, ecl_make_fixnum(narg),
value, type),
@':expected-type', type,
......@@ -324,7 +324,7 @@ FEwrong_type_key_arg(cl_object function, cl_object key, cl_object value, cl_obje
si_signal_simple_error(8,
@'type-error', /* condition name */
ECL_NIL, /* not correctable */
make_constant_base_string(message), /* format control */
ecl_make_constant_base_string(message,-1), /* format control */
cl_list(4, function, key, value, type),
@':expected-type', type,
@':datum', value);
......@@ -345,7 +345,7 @@ FEwrong_index(cl_object function, cl_object a, int which, cl_object ndx,
"takes a value ~D out of the range ~A.";
cl_object limit = ecl_make_integer(nonincl_limit-1);
cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), limit);
cl_object message = make_constant_base_string((which<0) ? message1 : message2);
cl_object message = ecl_make_constant_base_string((which<0) ? message1 : message2,-1);
cl_env_ptr env = ecl_process_env();
struct ecl_ihs_frame tmp_ihs;
function = cl_symbol_or_object(function);
......@@ -437,7 +437,7 @@ void
FEinvalid_function_name(cl_object fname)
{
cl_error(9, @'simple-type-error', @':format-control',
make_constant_base_string("Not a valid function name ~D."),
ecl_make_constant_base_string("Not a valid function name ~D.",-1),
@':format-arguments', cl_list(1, fname),
@':expected-type', cl_list(2, @'satisfies', @'si::valid-function-name-p'),
@':datum', fname);
......@@ -485,7 +485,7 @@ cl_object
_ecl_strerror(int code)
{
const char *error = strerror(code);
return make_base_string_copy(error);
return ecl_make_simple_base_string(error,-1);
}
/*************************************
......@@ -506,7 +506,7 @@ FElibc_error(const char *msg, int narg, ...)
rest = cl_grab_rest_args(args);
FEerror("~?~%C library explanation: ~A.", 3,
make_constant_base_string(msg), rest,
ecl_make_constant_base_string(msg,-1), rest,
error);
}
......@@ -524,14 +524,14 @@ FEwin32_error(const char *msg, int narg, ...)
0, GetLastError(), 0, (void*)&win_msg, 0, NULL) == 0)
win_msg_obj = unknown_error;
else {
win_msg_obj = make_base_string_copy(win_msg);
win_msg_obj = ecl_make_simple_base_string(win_msg,-1);
LocalFree(win_msg);
}
ecl_va_start(args, narg, narg, 0);
rest = cl_grab_rest_args(args);
FEerror("~?~%Windows library explanation: ~A.", 3,
make_constant_base_string(msg), rest,
ecl_make_constant_base_string(msg,-1), rest,
win_msg_obj);
}
#endif
......
......@@ -493,7 +493,7 @@ ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag tag)
return ecl_make_foreign_data(@':pointer-void', 0, *(void **)p);
case ECL_FFI_CSTRING:
return *(char **)p ?
ecl_make_simple_base_string(*(char **)p, -1) : ECL_NIL;
ecl_make_constant_base_string(*(char **)p, -1) : ECL_NIL;
case ECL_FFI_OBJECT:
return *(cl_object *)p;
case ECL_FFI_FLOAT:
......
......@@ -97,20 +97,20 @@ si_dump_c_backtrace(cl_object size)
pSymbol->MaxNameLen = MAX_SYMBOL_LENGTH;
# endif
int i;
cl_format(2, ECL_T, make_constant_base_string("~&C Backtrace:~%"));
cl_format(2, ECL_T, ecl_make_constant_base_string("~&C Backtrace:~%",-1));
for (i = 0; i < nframes; i++) {
# if defined(ECL_UNIX_BACKTRACE)
cl_format(3, ECL_T, make_constant_base_string(" > ~a~%"),
make_constant_base_string(names[i]));
cl_format(3, ECL_T, ecl_make_constant_base_string(" > ~a~%",-1),
ecl_make_constant_base_string(names[i],-1));
# elif defined(ECL_WINDOWS_BACKTRACE)
DWORD64 displacement;
if (SymFromAddr(process, (DWORD64) pointers[i], &displacement, pSymbol)) {
cl_format(5, ECL_T, make_constant_base_string(" > (~a+0x~x) [0x~x]~%"),
make_constant_base_string(pSymbol->Name),
cl_format(5, ECL_T, ecl_make_constant_base_string(" > (~a+0x~x) [0x~x]~%",-1),
ecl_make_constant_base_string(pSymbol->Name,-1),
ecl_make_unsigned_integer(displacement),
ecl_make_unsigned_integer((cl_index)pointers[i]));
} else {
cl_format(3, ECL_T, make_constant_base_string(" > (unknown) [0x~x]~%"),
cl_format(3, ECL_T, ecl_make_constant_base_string(" > (unknown) [0x~x]~%",-1),
ecl_make_unsigned_integer((cl_index)pointers[i]));
}
# endif
......
......@@ -99,7 +99,7 @@ static cl_object
copy_object_file(cl_object original)
{
int err;
cl_object copy = make_constant_base_string("TMP:ECL");
cl_object copy = ecl_make_constant_base_string("TMP:ECL",-1);
copy = si_coerce_to_filename(si_mkstemp(copy));
/*
* We either have to make a full copy to convince the loader to load this object
......@@ -124,7 +124,7 @@ copy_object_file(cl_object original)
#endif
#ifdef cygwin
{
cl_object new_copy = make_constant_base_string(".dll");
cl_object new_copy = ecl_make_constant_base_string(".dll",-1);
new_copy = si_base_string_concatenate(2, copy, new_copy);
cl_rename_file(2, copy, new_copy);
copy = new_copy;
......@@ -155,7 +155,7 @@ set_library_error(cl_object block) {
int number;
const char *filename;
NSLinkEditError(&c, &number, &filename, &message);
output = make_base_string_copy(message);
output = ecl_make_simple_base_string(message,-1);
}
#endif
#if defined(ECL_MS_WINDOWS_HOST)
......@@ -164,7 +164,7 @@ set_library_error(cl_object block) {
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
FORMAT_MESSAGE_ALLOCATE_BUFFER,
0, GetLastError(), 0, (void*)&message, 0, NULL);
output = make_base_string_copy(message);
output = ecl_make_simple_base_string(message,-1);
LocalFree(message);
}
#endif
......
......@@ -5523,7 +5523,7 @@ static cl_object
not_a_file_stream(cl_object strm)
{
cl_error(9, @'simple-type-error', @':format-control',
make_constant_base_string("~A is not an file stream"),
ecl_make_constant_base_string("~A is not an file stream",-1),
@':format-arguments', cl_list(1, strm),
@':expected-type', @'file-stream',
@':datum', strm);
......@@ -5533,7 +5533,7 @@ static void
not_an_input_stream(cl_object strm)
{
cl_error(9, @'simple-type-error', @':format-control',
make_constant_base_string("~A is not an input stream"),
ecl_make_constant_base_string("~A is not an input stream",-1),
@':format-arguments', cl_list(1, strm),
@':expected-type',
cl_list(2, @'satisfies', @'input-stream-p'),
......@@ -5544,7 +5544,7 @@ static void
not_an_output_stream(cl_object strm)
{
cl_error(9, @'simple-type-error', @':format-control',
make_constant_base_string("~A is not an output stream"),
ecl_make_constant_base_string("~A is not an output stream",-1),
@':format-arguments', cl_list(1, strm),
@':expected-type', cl_list(2, @'satisfies', @'output-stream-p'),
@':datum', strm);
......@@ -5554,7 +5554,7 @@ static void
not_a_character_stream(cl_object s)
{
cl_error(9, @'simple-type-error', @':format-control',
make_constant_base_string("~A is not a character stream"),
ecl_make_constant_base_string("~A is not a character stream",-1),
@':format-arguments', cl_list(1, s),
@':expected-type', @'character',
@':datum', cl_stream_element_type(s));
......@@ -5564,7 +5564,7 @@ static void
not_a_binary_stream(cl_object s)
{
cl_error(9, @'simple-type-error', @':format-control',
make_constant_base_string("~A is not a binary stream"),
ecl_make_constant_base_string("~A is not a binary stream",-1),
@':format-arguments', cl_list(1, s),
@':expected-type', @'integer',
@':datum', cl_stream_element_type(s));
......@@ -5587,8 +5587,8 @@ file_libc_error(cl_object error_type, cl_object stream,
rest = cl_grab_rest_args(args);
si_signal_simple_error(4, (cl_object)(cl_symbols + ecl_fixnum(error_type)), Cnil,
make_constant_base_string("~?~%C library explanation: ~A."),
cl_list(3, make_constant_base_string(msg), rest,
ecl_make_constant_base_string("~?~%C library explanation: ~A.",-1),
cl_list(3, ecl_make_constant_base_string(msg,-1), rest,
error));
_ecl_unexpected_return();
}
......@@ -5694,13 +5694,13 @@ wsock_error( const char *err_msg, cl_object strm )
cl_object msg_obj;
/* ecl_disable_interrupts(); ** done by caller */
{
FormatMessage( FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER,
0, WSAGetLastError(), 0, ( void* )&msg, 0, NULL );
msg_obj = make_base_string_copy( msg );
LocalFree( msg );
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER,
0, WSAGetLastError(), 0, (void*)&msg, 0, NULL);
msg_obj = ecl_make_simple_base_string(msg,-1);
LocalFree(msg);
}
ecl_enable_interrupts();
FEerror( err_msg, 2, strm, msg_obj );
FEerror(err_msg, 2, strm, msg_obj);
}
#endif
......@@ -5726,7 +5726,7 @@ init_file(void)
flags = ECL_STREAM_DEFAULT_FORMAT;
#endif
null_stream = ecl_make_stream_from_FILE(make_constant_base_string("/dev/null"),
null_stream = ecl_make_stream_from_FILE(ecl_make_constant_base_string("/dev/null",-1),
NULL, ecl_smm_io, 8, flags, external_format);
generic_close(null_stream);
null_stream = cl_make_two_way_stream(null_stream, cl_make_broadcast_stream(0));
......@@ -5735,20 +5735,20 @@ init_file(void)
/* We choose C streams by default only when _not_ using threads.
* The reason is that C streams block on I/O operations. */
#if !defined(ECL_THREADS)
standard_input = maybe_make_windows_console_FILE(make_constant_base_string("stdin"),
standard_input = maybe_make_windows_console_FILE(ecl_make_constant_base_string("stdin",-1),
stdin, ecl_smm_input, 8, flags, external_format);
standard_output = maybe_make_windows_console_FILE(make_constant_base_string("stdout"),
standard_output = maybe_make_windows_console_FILE(ecl_make_constant_base_string("stdout",-1),
stdout, ecl_smm_output, 8, flags, external_format);
error_output = maybe_make_windows_console_FILE(make_constant_base_string("stderr"),
error_output = maybe_make_windows_console_FILE(ecl_make_constant_base_string("stderr",-1),
stderr, ecl_smm_output, 8, flags, external_format);
#else
standard_input = maybe_make_windows_console_fd(make_constant_base_string("stdin"),
standard_input = maybe_make_windows_console_fd(ecl_make_constant_base_string("stdin",-1),
STDIN_FILENO, ecl_smm_input_file, 8, flags,
external_format);
standard_output = maybe_make_windows_console_fd(make_constant_base_string("stdout"),
standard_output = maybe_make_windows_console_fd(ecl_make_constant_base_string("stdout",-1),
STDOUT_FILENO, ecl_smm_output_file, 8, flags,
external_format);
error_output = maybe_make_windows_console_fd(make_constant_base_string("stderr"),
error_output = maybe_make_windows_console_fd(ecl_make_constant_base_string("stderr",-1),
STDERR_FILENO, ecl_smm_output_file, 8, flags,
external_format);
#endif
......
......@@ -113,7 +113,7 @@ static void
fmt_error(format_stack fmt, const char *s)
{
cl_error(7, @'si::format-error',
@':format-control', make_constant_base_string(s),
@':format-control', ecl_make_constant_base_string(s,-1),
@':control-string', fmt->ctl_str,
@':offset', ecl_make_fixnum(fmt->ctl_index));
}
......@@ -2220,8 +2220,7 @@ format(format_stack fmt, cl_index start, cl_index end)
if (!ECL_ARRAY_HAS_FILL_POINTER_P(output)) {
cl_error(7, @'si::format-error',
@':format-control',
make_constant_base_string(
"Cannot output to a non adjustable string."),
ecl_make_constant_base_string("Cannot output to a non adjustable string.",-1),
@':control-string', string,
@':offset', ecl_make_fixnum(0));
}
......
......@@ -52,7 +52,7 @@ si_load_binary(cl_object filename, cl_object verbose,
prefix = @si::base-string-concatenate(3,
init_prefix,
prefix,
make_constant_base_string("_"));
ecl_make_constant_base_string("_",-1));
}
basename = cl_pathname_name(1,filename);
basename = @si::base-string-concatenate(2, prefix, @string-upcase(1, funcall(4, @'nsubstitute', ECL_CODE_CHAR('_'), ECL_CODE_CHAR('-'), basename)));
......@@ -263,7 +263,7 @@ si_load_bytecodes(cl_object source, cl_object verbose, cl_object print, cl_objec
}
NOT_A_FILENAME:
if (verbose != ECL_NIL) {
cl_format(3, ECL_T, make_constant_base_string("~&;;; Loading ~s~%"),
cl_format(3, ECL_T, ecl_make_constant_base_string("~&;;; Loading ~s~%",-1),
filename);
}
ecl_bds_bind(the_env, @'*package*', ecl_symbol_value(@'*package*'));
......@@ -297,7 +297,7 @@ si_load_bytecodes(cl_object source, cl_object verbose, cl_object print, cl_objec
FEerror("LOAD: Could not load file ~S (Error: ~S)",
2, filename, ok);
if (print != ECL_NIL) {
cl_format(3, ECL_T, make_constant_base_string("~&;;; Loading ~s~%"),
cl_format(3, ECL_T, ecl_make_constant_base_string("~&;;; Loading ~s~%",-1),
filename);
}
@(return filename);
......
......@@ -852,7 +852,7 @@ si_argv(cl_object index)
if (ECL_FIXNUMP(index)) {
cl_fixnum i = ecl_fixnum(index);
if (i >= 0 && i < ARGC) {
@(return make_base_string_copy(ARGV[i]));
@(return ecl_make_simple_base_string(ARGV[i],-1));
}
}
FEerror("Illegal argument index: ~S.", 1, index);
......@@ -866,7 +866,7 @@ si_getenv(cl_object var)
/* Strings have to be null terminated base strings */
var = si_copy_to_simple_base_string(var);
value = getenv((char*)var->base_string.self);
@(return ((value == NULL)? ECL_NIL : make_base_string_copy(value)));
@(return ((value == NULL)? ECL_NIL : ecl_make_simple_base_string(value,-1)));
}
#if defined(HAVE_SETENV) || defined(HAVE_PUTENV)
......@@ -898,7 +898,7 @@ si_setenv(cl_object var, cl_object value)
ret_val = setenv((char*)var->base_string.self,
(char*)value->base_string.self, 1);
#else
value = cl_format(4, ECL_NIL, make_constant_base_string("~A=~A"), var,
value = cl_format(4, ECL_NIL, ecl_make_constant_base_string("~A=~A",-1), var,
value);
value = si_copy_to_simple_base_string(value);
putenv((char*)value->base_string.self);
......@@ -919,14 +919,14 @@ si_environ(void)
char **p;
extern char **environ;
for (p = environ; *p; p++) {
output = CONS(make_constant_base_string(*p), output);
output = CONS(ecl_make_constant_base_string(*p,-1), output);
}
output = cl_nreverse(output);
#else
# if defined(ECL_MS_WINDOWS_HOST)
LPTCH p;
for (p = GetEnvironmentStrings(); *p; ) {
output = CONS(make_constant_base_string(p), output);
output = CONS(ecl_make_constant_base_string(p,-1), output);
do { (void)0; } while (*(p++));
}
output = cl_nreverse(output);
......
......@@ -42,7 +42,7 @@ FEpackage_error(const char *message, cl_object package, int narg, ...)
si_signal_simple_error(6,
@'package-error',
ECL_NIL, /* not correctable */
make_constant_base_string(message), /* format control */
ecl_make_constant_base_string(message,-1), /* format control */
narg? cl_grab_rest_args(args) : cl_list(1,package), /* format args */
@':package', package); /* extra arguments */
}
......@@ -57,8 +57,8 @@ CEpackage_error(const char *message, const char *continue_message, cl_object pac
ecl_va_end(args);
si_signal_simple_error(6,
@'package-error',
make_constant_base_string(continue_message),
make_constant_base_string(message), /* format control */
ecl_make_constant_base_string(continue_message,-1),
ecl_make_constant_base_string(message,-1), /* format control */
arg,
@':package', package);
}
......@@ -380,7 +380,7 @@ cl_object
_ecl_intern(const char *s, cl_object p)
{
int intern_flag;
cl_object str = make_constant_base_string(s);
cl_object str = ecl_make_constant_base_string(s,-1);
return ecl_intern(str, p, &intern_flag);
}
......
......@@ -775,7 +775,7 @@ cl_logical_pathname(cl_object x)
x = cl_pathname(x);
if (!x->pathname.logical) {
cl_error(9, @'simple-type-error', @':format-control',
make_constant_base_string("~S cannot be coerced to a logical pathname."),
ecl_make_constant_base_string("~S cannot be coerced to a logical pathname.",-1),
@':format-arguments', cl_list(1, x),
@':expected-type', @'logical-pathname',
@':datum', x);
......
......@@ -1797,7 +1797,7 @@ static void
error_locked_readtable(cl_object r)
{
cl_error(2,
make_constant_base_string("Cannot modify locked readtable ~A."),
ecl_make_constant_base_string("Cannot modify locked readtable ~A.",-1),
r);
}
......
......@@ -69,7 +69,7 @@ ecl_cs_overflow(void)
ecl_unrecoverable_error(env, stack_overflow_msg);
if (env->cs_max_size == (cl_index)0 || env->cs_size < env->cs_max_size)
si_serror(6, make_constant_base_string("Extend stack size"),
si_serror(6, ecl_make_constant_base_string("Extend stack size",-1),
@'ext::stack-overflow',
@':size', ecl_make_fixnum(size),
@':type', @'ext::c-stack');
......@@ -168,7 +168,7 @@ ecl_bds_overflow(void)
ecl_unrecoverable_error(env, stack_overflow_msg);
}
env->bds_limit += margin;
si_serror(6, make_constant_base_string("Extend stack size"),
si_serror(6, ecl_make_constant_base_string("Extend stack size",-1),
@'ext::stack-overflow', @':size', ecl_make_fixnum(size),
@':type', @'ext::binding-stack');
ecl_bds_set_size(env, size + (size / 2));
......@@ -540,7 +540,7 @@ frs_overflow(void) /* used as condition in list.d */
ecl_unrecoverable_error(env, stack_overflow_msg);
}
env->frs_limit += margin;
si_serror(6, make_constant_base_string("Extend stack size"),
si_serror(6, ecl_make_constant_base_string("Extend stack size",-1),
@'ext::stack-overflow', @':size', ecl_make_fixnum(size),
@':type', @'ext::frame-stack');
frs_set_size(env, size + size / 2);
......
......@@ -106,13 +106,14 @@ ecl_alloc_adjustable_extended_string(cl_index l)
/*
ecl_make_simple_base_string(s) creates a simple-base string from C string s.
ecl_make_constant_base_string(s) does the same, but without copying the C string.
*/
cl_object
ecl_make_simple_base_string(char *s, cl_fixnum l)
ecl_make_constant_base_string(const char *s, cl_fixnum l)
{
cl_object x = ecl_alloc_object(t_base_string);
x->base_string.elttype = ecl_aet_bc;
x->base_string.flags = 0; /* no fill pointer, no adjustable */
x->base_string.flags = 0; /* no fill pointer, not adjustable */
x->base_string.displaced = ECL_NIL;
if (l < 0) l = strlen(s);
x->base_string.dim = (x->base_string.fillp = l);
......@@ -121,10 +122,10 @@ ecl_make_simple_base_string(char *s, cl_fixnum l)
}
cl_object
make_base_string_copy(const char *s)
ecl_make_simple_base_string(const char *s, cl_fixnum l)
{
cl_object x;
cl_index l = strlen(s);
if (l < 0) l = strlen(s);
x = ecl_alloc_simple_base_string(l);
memcpy(x->base_string.self, s, l);
......@@ -137,7 +138,7 @@ ecl_cstring_to_base_string_or_nil(const char *s)
if (s == NULL)
return ECL_NIL;
else
return make_base_string_copy(s);
return ecl_make_simple_base_string(s,-1);
}
bool
......
......@@ -153,7 +153,7 @@ static void
FEtype_error_plist(cl_object x)
{
cl_error(9, @'simple-type-error', @':format-control',
make_constant_base_string("Not a valid property list ~D"),
ecl_make_constant_base_string("Not a valid property list ~D",-1),
@':format-arguments', cl_list(1, x),
@':expected-type', @'si::property-list',
@':datum', x);
......
......@@ -404,10 +404,10 @@ si_lookup_host_entry(cl_object host_or_address)
if (he == NULL) {
@(return ECL_NIL ECL_NIL ECL_NIL);
}
name = make_base_string_copy(he->h_name);
name = ecl_make_simple_base_string(he->h_name,-1);
aliases = ECL_NIL;
for (i = 0; he->h_aliases[i] != 0; i++)
aliases = CONS(make_base_string_copy(he->h_aliases[i]), aliases);
aliases = CONS(ecl_make_simple_base_string(he->h_aliases[i],-1), aliases);
addresses = ECL_NIL;
for (i = 0; he->h_addr_list[i]; i++) {
unsigned long *s = (unsigned long*)(he->h_addr_list[i]);
......
......@@ -57,7 +57,7 @@ FEunknown_rwlock_error(cl_object lock, int rc)
1, lock);
}
FEerror("When acting on rwlock ~A, got the following C library error:~%"
"~A", 2, lock, make_constant_base_string(msg));
"~A", 2, lock, ecl_make_constant_base_string(msg,-1));
#endif
}
......
......@@ -181,7 +181,7 @@ cl_sleep(cl_object z)
/* INV: ecl_minusp() makes sure `z' is real */
if (ecl_minusp(z))
cl_error(9, @'simple-type-error', @':format-control',
make_constant_base_string("Not a non-negative number ~S"),
ecl_make_constant_base_string("Not a non-negative number ~S",-1),
@':format-arguments', cl_list(1, z),
@':expected-type', @'real', @':datum', z);
/* Compute time without overflows */
......
......@@ -39,7 +39,7 @@ FEtype_error_list(cl_object x) {
void
FEtype_error_proper_list(cl_object x) {
cl_error(9, @'simple-type-error', @':format-control',
make_constant_base_string("Not a proper list ~D"),
ecl_make_constant_base_string("Not a proper list ~D",-1),
@':format-arguments', cl_list(1, x),
@':expected-type', ecl_read_from_cstring("si::proper-list"),
@':datum', x);
......@@ -51,7 +51,7 @@ FEcircular_list(cl_object x)
/* FIXME: Is this the right way to rebind it? */
ecl_bds_bind(ecl_process_env(), @'*print-circle*', ECL_T);
cl_error(9, @'simple-type-error', @':format-control',
make_constant_base_string("Circular list ~D"),
ecl_make_constant_base_string("Circular list ~D",-1),
@':format-arguments', cl_list(1, x),
@':expected-type', @'list',
@':datum', x);
......@@ -63,7 +63,7 @@ FEtype_error_index(cl_object seq, cl_fixnum ndx)
cl_object n = ecl_make_fixnum(ndx);
cl_index l = ECL_INSTANCEP(seq)? seq->instance.length : ecl_length(seq);
cl_error(9, @'simple-type-error', @':format-control',
make_constant_base_string("~S is not a valid index into the object ~S"),
ecl_make_constant_base_string("~S is not a valid index into the object ~S",-1),
@':format-arguments', cl_list(2, n, seq),
@':expected-type', cl_list(3, @'integer', ecl_make_fixnum(0), ecl_make_fixnum(l-1)),
@':datum', n);
......@@ -91,7 +91,7 @@ ecl_type_error(cl_object function, const char *place, cl_object o,
cl_object type)
{
return si_wrong_type_argument(4, o, type,
(*place? make_constant_base_string(place) : ECL_NIL),
(*place? ecl_make_constant_base_string(place,-1) : ECL_NIL),
function);
}
......
......@@ -542,7 +542,7 @@ _ecl_ucd_code_to_name(ecl_character c)
char buffer[ECL_UCD_LARGEST_CHAR_NAME+1];
buffer[0] = 0;
fill_pair_name(buffer, pair);
return make_base_string_copy(buffer);
return ecl_make_simple_base_string(buffer,-1);
}
}
......
......@@ -53,7 +53,7 @@ static int
safe_chdir(const char *path, cl_object prefix)
{
if (prefix != ECL_NIL) {
cl_object aux = make_constant_base_string(path);
cl_object aux = ecl_make_constant_base_string(path,-1);
aux = si_base_string_concatenate(2, prefix, aux);
return safe_chdir((char *)aux->base_string.self, ECL_NIL);
} else {
......@@ -95,7 +95,7 @@ drive_host_prefix(cl_object pathname)