sfos/ecl
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
clean up functions creating base strings from C strings

Closes #462

See merge request embeddable-common-lisp/ecl!131
This commit is contained in:
Daniel Kochmański 2019-01-07 19:55:49 +00:00
commit 6982a805f1
33 changed files with 129 additions and 129 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
src/c/all_symbols.d
View file

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

2
src/c/alloc_2.d
View file

@ -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:

2
src/c/character.d
View file

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

2
src/c/disassembler.d
View file

@ -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:

34
src/c/error.d
View file

@ -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

2
src/c/ffi.d
View file

@ -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:

12
src/c/ffi/backtrace.d
View file

@ -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

8
src/c/ffi/libraries.d
View file

@ -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

38
src/c/file.d
View file

@ -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

5
src/c/format.d
View file

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

6
src/c/load.d
View file

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

10
src/c/main.d
View file

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

8
src/c/package.d
View file

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

2
src/c/pathname.d
View file

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

2
src/c/read.d
View file

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

6
src/c/stacks.d
View file

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

11
src/c/string.d
View file

@ -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

2
src/c/symbol.d
View file

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

4
src/c/tcp.d
View file

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

2
src/c/threads/rwlock.d
View file

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

2
src/c/time.d
View file

@ -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 */

8
src/c/typespec.d
View file

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

2
src/c/unicode/ucd_names_char.c
View file

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

30
src/c/unixfsys.d
View file

@ -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)
cl_object host = pathname->pathname.host;
cl_object output = ECL_NIL;
if (device != ECL_NIL) {
output = make_base_string_copy("X:");
output = ecl_make_simple_base_string("X:",-1);
output->base_string.self[0] = device->base_string.self[0];
}
if (host != ECL_NIL) {
@ -253,7 +253,7 @@ enter_directory(cl_object base_dir, cl_object subdir, bool ignore_if_failure)
/* Nothing to do */
return base_dir;
} else if (subdir == @':up') {
aux = make_constant_base_string("..");
aux = ecl_make_constant_base_string("..",-1);
} else if (!ECL_BASE_STRING_P(subdir)) {
unlikely_if (!ecl_fits_in_base_string(subdir))
FEerror("Directory component ~S found in pathname~& ~S"
@ -370,7 +370,7 @@ file_truename(cl_object pathname, cl_object filename, int flags)
pathname->pathname.type != ECL_NIL) {
pathname = si_base_string_concatenate
(2, filename,
make_constant_base_string("/"));
ecl_make_constant_base_string("/",-1));
pathname = cl_truename(pathname);
}
}
@ -659,10 +659,10 @@ cl_file_author(cl_object file)
ecl_disable_interrupts();
pwent = getpwuid(filestatus.st_uid);
ecl_enable_interrupts();
output = make_base_string_copy(pwent->pw_name);
output = ecl_make_simple_base_string(pwent->pw_name,-1);
}
#else
output = make_constant_base_string("UNKNOWN");
output = ecl_make_constant_base_string("UNKNOWN",-1);
#endif
@(return output);
}
@ -696,20 +696,20 @@ ecl_homedir_pathname(cl_object user)
pwent = getpwnam(p);
if (pwent == NULL)
FEerror("Unknown user ~S.", 1, p);
namestring = make_base_string_copy(pwent->pw_dir);
namestring = ecl_make_simple_base_string(pwent->pw_dir,-1);
#endif
FEerror("Unknown user ~S.", 1, p);
} else if ((h = getenv("HOME"))) {
namestring = make_base_string_copy(h);
namestring = ecl_make_simple_base_string(h,-1);
#if defined(ECL_MS_WINDOWS_HOST)
} else if ((h = getenv("HOMEPATH")) && (d = getenv("HOMEDRIVE"))) {
namestring =
si_base_string_concatenate(2,
make_constant_base_string(d),
make_constant_base_string(h));
ecl_make_constant_base_string(d,-1),
ecl_make_constant_base_string(h,-1));
#endif
} else {
namestring = make_constant_base_string("/");
namestring = ecl_make_constant_base_string("/",-1);
}
if (namestring->base_string.self[0] == '~') {
FEerror("Not a valid home pathname ~S", 1, namestring);
@ -750,7 +750,7 @@ string_match(const char *s, cl_object pattern)
continue; \
if (!string_match(text, text_mask)) \
continue; \
component = make_constant_base_string(text); \
component = ecl_make_constant_base_string(text,-1); \
component = si_base_string_concatenate(2, prefix, component); \
component_path = cl_pathname(component); \
if (!Null(pathname_mask)) { \
@ -802,7 +802,7 @@ list_directory(cl_object base_dir, cl_object text_mask, cl_object pathname_mask,
ecl_disable_interrupts();
for (;;) {
if (hFind == NULL) {
cl_object aux = make_constant_base_string(".\\*");
cl_object aux = ecl_make_constant_base_string(".\\*",-1);
cl_object mask = si_base_string_concatenate(2, prefix, aux);
hFind = FindFirstFile((char*)mask->base_string.self, &fd);
if (hFind == INVALID_HANDLE_VALUE) {
@ -1001,7 +1001,7 @@ si_get_library_pathname(void)
} else {
const char *v = getenv("ECLDIR");
if (v) {
s = make_constant_base_string(v);
s = ecl_make_constant_base_string(v,-1);
goto OUTPUT;
}
}
@ -1029,7 +1029,7 @@ si_get_library_pathname(void)
s = ecl_namestring(s, ECL_NAMESTRING_FORCE_BASE_STRING);
}
#else
s = make_constant_base_string(ECLDIR "/");
s = ecl_make_constant_base_string(ECLDIR "/",-1);
#endif
OUTPUT:
{

2
src/c/unixint.d
View file

@ -1448,7 +1448,7 @@ create_signal_code_constants()
char buffer[64];
cl_object name;
sprintf(buffer, "+SIGRT%d+", i-SIGRTMIN);
name = ecl_intern(make_base_string_copy(buffer),
name = ecl_intern(ecl_make_simple_base_string(buffer,-1),
cl_core.ext_package,
intern_flag);
add_one_signal(hash, i, name, ECL_NIL);

6
src/c/unixsys.d
View file

@ -299,7 +299,7 @@ create_descriptor(cl_object stream, cl_object direction,
HANDLE stream_handle = ecl_stream_to_HANDLE
(stream, direction != @':input');
if (stream_handle == INVALID_HANDLE_VALUE) {
CEerror(make_constant_base_string("Create a new stream."),
CEerror(ecl_make_constant_base_string("Create a new stream.",-1),
"~S argument to RUN-PROGRAM does not have a file handle:~%~S",
2, direction, stream);
create_descriptor(@':stream', direction, child, parent);
@ -337,7 +337,7 @@ create_descriptor(cl_object stream, cl_object direction,
if (*child >= 0) {
*child = dup(*child);
} else {
CEerror(make_constant_base_string("Create a new stream."),
CEerror(ecl_make_constant_base_string("Create a new stream.",-1),
"~S argument to RUN-PROGRAM does not have a file handle:~%~S",
2, direction, stream);
create_descriptor(@':stream', direction, child, parent);
@ -360,7 +360,7 @@ si_run_program_inner(cl_object command, cl_object argv, cl_object environ) {
#if defined(ECL_MS_WINDOWS_HOST)
argv = cl_format(4, ECL_NIL,
make_simple_base_string("~A~{ ~A~}"),
ecl_make_constant_base_string("~A~{ ~A~}",-1),
command, argv);
argv = si_copy_to_simple_base_string(argv);
#else

4
src/cmp/cmpmain.lsp
View file

@ -455,7 +455,7 @@ filesystem or in the database of ASDF modules."
(wt-filtered-data (write-to-string epilogue-code) stream)
(princ ";
cl_object output;
si_select_package(ecl_make_simple_base_string(\"CL-USER\", 7));
si_select_package(ecl_make_constant_base_string(\"CL-USER\", 7));
output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL);
}" stream)
)))))
@ -471,7 +471,7 @@ output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL);
(wt-filtered-data (write-to-string prologue-code) stream)
(princ ";
cl_object output;
si_select_package(ecl_make_simple_base_string(\"CL-USER\", 7));
si_select_package(ecl_make_constant_base_string(\"CL-USER\", 7));
output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL);
}" stream)
)))))

4
src/cmp/cmptop.lsp
View file

@ -155,8 +155,8 @@
(wt-nl "flag->cblock.cfuns_size = compiler_cfuns_size;")
(wt-nl "flag->cblock.cfuns = compiler_cfuns;")
(when ext:*source-location*
(wt-nl "flag->cblock.source = make_constant_base_string(\""
(namestring (car ext:*source-location*)) "\");"))
(wt-nl "flag->cblock.source = ecl_make_constant_base_string(\""
(namestring (car ext:*source-location*)) "\",-1);"))
(wt-nl "return;}")
(wt-nl "#ifdef ECL_DYNAMIC_VV")
(wt-nl "VV = Cblock->cblock.data;")

4
src/doc/manual/standards/strings.txi
View file

@ -39,9 +39,9 @@ Building strings of C data
@end deftypefun
@deftypefun cl_object ecl_alloc_adjustable_simple_string (cl_index @var{length});
@end deftypefun
@deftypefun cl_object ecl_make_simple_base_string (ecl_base_char* @var{data}, cl_fixnum @var{length});
@deftypefun cl_object ecl_make_simple_base_string (const char* @var{data}, cl_fixnum @var{length});
@end deftypefun
@deftypefun cl_object ecl_make_constant_base_string (ecl_base_char* @var{data}, cl_fixnum @var{length});
@deftypefun cl_object ecl_make_constant_base_string (const char* @var{data}, cl_fixnum @var{length});
@end deftypefun
@subsubheading Description

9
src/h/external.h
View file

@ -1534,8 +1534,8 @@ extern ECL_API cl_object ecl_copy_readtable(cl_object from, cl_object to);
extern ECL_API cl_object ecl_current_readtable(void);
extern ECL_API int ecl_current_read_base(void);
extern ECL_API char ecl_current_read_default_float_format(void);
#define ecl_read_from_cstring(s) si_string_to_object(1,make_constant_base_string(s))
#define ecl_read_from_cstring_safe(s,v) si_string_to_object(2,make_constant_base_string(s),(v))
#define ecl_read_from_cstring(s) si_string_to_object(1,ecl_make_constant_base_string(s,-1))
#define ecl_read_from_cstring_safe(s,v) si_string_to_object(2,ecl_make_constant_base_string(s,-1),(v))
extern ECL_API cl_object ecl_init_module(cl_object block, void (*entry)(cl_object));
/* reference.c */
@ -1658,9 +1658,8 @@ extern ECL_API cl_object si_copy_to_simple_base_string(cl_object s);
#define ecl_alloc_simple_base_string(l) ecl_alloc_simple_vector((l),ecl_aet_bc)
extern ECL_API cl_object ecl_alloc_adjustable_base_string(cl_index l);
extern ECL_API cl_object ecl_make_simple_base_string(char *s, cl_fixnum i);
#define ecl_make_constant_base_string(s,n) ecl_make_simple_base_string((char*)s,n)
extern ECL_API cl_object make_base_string_copy(const char *s);
extern ECL_API cl_object ecl_make_constant_base_string(const char *s, cl_fixnum i);
extern ECL_API cl_object ecl_make_simple_base_string(const char *s, cl_fixnum i);
extern ECL_API cl_object ecl_cstring_to_base_string_or_nil(const char *s);
extern ECL_API bool ecl_string_eq(cl_object x, cl_object y);
extern ECL_API bool ecl_member_char(ecl_character c, cl_object char_bag);

3
src/h/legacy.h
View file

@ -84,7 +84,8 @@
#endif /* !ECL_LEGACY_H && !ECL_NO_LEGACY */
#define make_simple_base_string(s) ecl_make_simple_base_string((s),-1)
#define make_constant_base_string(s) ecl_make_simple_base_string((char *)(s),-1)
#define make_constant_base_string(s) ecl_make_constant_base_string((char *)(s),-1)
#define make_base_string_copy(s) ecl_make_simple_base_string((s),-1)
#define stp_ordinary ecl_stp_ordinary
#define stp_constant ecl_stp_constant

10
src/lsp/config.lsp.in
View file

@ -20,11 +20,11 @@
if (uname(&aux) < 0)
output = ECL_NIL;
else
output = cl_list(5, make_base_string_copy(aux.sysname),
make_base_string_copy(aux.nodename),
make_base_string_copy(aux.release),
make_base_string_copy(aux.version),
make_base_string_copy(aux.machine));
output = cl_list(5, ecl_make_simple_base_string(aux.sysname,-1),
ecl_make_simple_base_string(aux.nodename,-1),
ecl_make_simple_base_string(aux.release,-1),
ecl_make_simple_base_string(aux.version,-1),
ecl_make_simple_base_string(aux.machine,-1));
@(return) = output;
}" :one-liner nil))

2
src/lsp/top.lsp
View file

@ -888,7 +888,7 @@ Use special code 0 to cancel this operation.")
cl_index ndx = #1;
typedef struct ecl_var_debug_info *pinfo;
pinfo d = (pinfo)(v->vector.self.t[1]) + ndx;
cl_object name = make_constant_base_string(d->name);
cl_object name = ecl_make_constant_base_string(d->name,-1);
void *value = (void*)(v->vector.self.t[2+ndx]);
cl_object output;
switch (d->type) {