void
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, ECL_SYM("SIMPLE-TYPE-ERROR",773), ECL_SYM(":FORMAT-CONTROL",1240),
make_constant_base_string("~S is not a valid index into the object ~S"),
ECL_SYM(":FORMAT-ARGUMENTS",1239), cl_list(2, n, seq),
ECL_SYM(":EXPECTED-TYPE",1232), cl_list(3, ECL_SYM("INTEGER",437), ecl_make_fixnum(0), ecl_make_fixnum(l-1)),
ECL_SYM(":DATUM",1214), n);
}
cl_object
_ecl_ucd_name_to_code(cl_object name)
{
int mid, low = 0, up = ECL_UCD_TOTAL_NAMES-1;
int l = ecl_length(name);
if (l <= ECL_UCD_LARGEST_CHAR_NAME) {
char buffer1[ECL_UCD_LARGEST_CHAR_NAME+1];
char buffer2[ECL_UCD_LARGEST_CHAR_NAME+1];
for (mid = 0; mid < l; mid++) {
ecl_character c = ecl_char_upcase(ecl_char(name, mid));
buffer1[mid] = c;
if (c < 32 || c > 127) /* All character names are [-A-Z_0-9]* */
return ECL_NIL;
}
buffer1[mid] = 0;
do {
ecl_ucd_code_and_pair p = ecl_ucd_sorted_pairs[mid = (low + up) / 2];
int flag, pair = ((unsigned int)p.pair[1] << 8) | p.pair[0];
buffer2[0] = 0;
fill_pair_name(buffer2, pair);
flag = strcmp(buffer1, buffer2);
/*
printf("[%d,%d,%d] %s <> (%d)%s -> %d\n",
low, mid, up, buffer1, pair, buffer2, flag);
*/
if (flag == 0) {
return ecl_make_fixnum(((unsigned int)p.code[2] << 16) |
((unsigned int)p.code[1] << 8) |
p.code[0]);
} else if (flag < 0) {
up = mid - 1;
} else {
low = mid + 1;
}
} while (low <= up);
}
return ECL_NIL;
}
cl_object si_mangle_name(cl_narg narg, ...)
{
#line 81
// ------------------------------2
#line 81
const cl_env_ptr the_env = ecl_process_env();
#line 81
cl_object as_function;
#line 81
va_list ARGS;
va_start(ARGS, narg);
cl_object symbol = va_arg(ARGS,cl_object);
#line 81
// ------------------------------3
cl_index l;
unsigned char c, *source, *dest;
cl_object output;
cl_object package;
cl_object found = ECL_NIL;
cl_object maxarg = ecl_make_fixnum(ECL_CALL_ARGUMENTS_LIMIT);
cl_object minarg = ecl_make_fixnum(0);
bool is_symbol;
cl_object name;
#line 92
// ------------------------------4
#line 92
#line 92
if (ecl_unlikely(narg < 1|| narg > 2)) FEwrong_num_arguments(ecl_make_fixnum(1107));
#line 92
if (narg > 1) {
#line 92
as_function = va_arg(ARGS,cl_object);
#line 92
} else {
#line 92
as_function = ECL_NIL;
#line 92
}
#line 92
// ------------------------------5
name = ecl_symbol_name(symbol);
is_symbol = Null(as_function);
if (is_symbol) {
cl_fixnum p;
if (symbol == ECL_NIL)
{
#line 97
#line 97
cl_object __value0 = ECL_T;
#line 97
cl_object __value1 = make_constant_base_string("ECL_NIL");
#line 97
the_env->nvalues = 2;
#line 97
the_env->values[1] = __value1;
#line 97
return __value0;
#line 97
}
else if (symbol == ECL_T)
{
#line 99
#line 99
cl_object __value0 = ECL_T;
#line 99
cl_object __value1 = make_constant_base_string("ECL_T");
#line 99
the_env->nvalues = 2;
#line 99
the_env->values[1] = __value1;
#line 99
return __value0;
#line 99
}
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)"),
name, ecl_make_fixnum(p));
{
#line 106
#line 106
cl_object __value0 = found;
#line 106
cl_object __value1 = output;
#line 106
cl_object __value2 = maxarg;
#line 106
the_env->nvalues = 3;
#line 106
the_env->values[2] = __value2;
#line 106
the_env->values[1] = __value1;
#line 106
return __value0;
#line 106
}
}
} else if (!Null(symbol)) {
cl_object fun = symbol->symbol.gfdef;
cl_type t = (fun == OBJNULL)? t_other : type_of(fun);
if ((t == t_cfun || t == t_cfunfixed) && fun->cfun.block == OBJNULL) {
for (l = 0; l <= cl_num_symbols_in_core; l++) {
cl_object s = (cl_object)(cl_symbols + l);
if (fun == ECL_SYM_FUN(s)) {
symbol = s;
found = ECL_T;
if (fun->cfun.narg >= 0) {
minarg =
maxarg = ecl_make_fixnum(fun->cfun.narg);
}
break;
}
}
}
}
package = ecl_symbol_package(symbol);
if (Null(package))
;
else if (package == cl_core.lisp_package)
package = make_constant_base_string("cl");
else if (package == cl_core.system_package)
package = make_constant_base_string("si");
else if (package == cl_core.ext_package)
package = make_constant_base_string("si");
else if (package == cl_core.keyword_package)
package = ECL_NIL;
else
package = package->pack.name;
symbol = ecl_symbol_name(symbol);
l = symbol->base_string.fillp;
source = symbol->base_string.self;
output = ecl_alloc_simple_base_string(ecl_length(package) + l + 1);
if (is_symbol && source[0] == '*') {
if (l > 2 && source[l-1] == '*') l--;
c = 'V';
l--;
source++;
} else if (is_symbol && l > 2 && source[0] == '+' && source[l-1] == '+') {
c = 'C';
l-= 2;
source++;
} else if (!is_symbol) {
c = '_';
} else if (package == cl_core.keyword_package) {
c = 'K';
} else {
c = 'S';
}
output->base_string.fillp = 0;
if (!Null(package))
if (!mangle_name(output, package->base_string.self, package->base_string.fillp))
{
#line 162
#line 162
cl_object __value0 = ECL_NIL;
#line 162
cl_object __value1 = ECL_NIL;
#line 162
cl_object __value2 = maxarg;
#line 162
the_env->nvalues = 3;
#line 162
the_env->values[2] = __value2;
#line 162
the_env->values[1] = __value1;
#line 162
return __value0;
#line 162
}
output->base_string.self[output->base_string.fillp++] = c;
if (!(dest = mangle_name(output, source, l)))
{
#line 165
#line 165
cl_object __value0 = ECL_NIL;
#line 165
cl_object __value1 = ECL_NIL;
#line 165
cl_object __value2 = maxarg;
#line 165
the_env->nvalues = 3;
#line 165
the_env->values[2] = __value2;
#line 165
the_env->values[1] = __value1;
#line 165
return __value0;
#line 165
}
if (dest[-1] == '_')
dest[-1] = 'M';
*(dest++) = '\0';
{
#line 169
#line 169
cl_object __value0 = found;
#line 169
cl_object __value1 = output;
#line 169
cl_object __value2 = minarg;
#line 169
cl_object __value3 = maxarg;
#line 169
the_env->nvalues = 4;
#line 169
the_env->values[3] = __value3;
#line 169
the_env->values[2] = __value2;
#line 169
the_env->values[1] = __value1;
#line 169
return __value0;
#line 169
}
}
