static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) {
int i;
if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x)
|| sexp_flonump(x) || sexp_bignump(x)) {
sexp_write(ctx, x, out);
} else if (depth <= 0) {
goto print_name;
} else if (sexp_synclop(x)) {
sexp_write_string(ctx, "#<sc ", out);
sexp_print_simple(ctx, sexp_synclo_expr(x), out, depth);
sexp_write_string(ctx, ">", out);
} else if (sexp_pairp(x)) {
sexp_write_char(ctx, '(', out);
sexp_print_simple(ctx, sexp_car(x), out, depth-1);
sexp_write_string(ctx, " . ", out);
sexp_print_simple(ctx, sexp_cdr(x), out, depth-1);
sexp_write_char(ctx, ')', out);
} else if (sexp_vectorp(x)) {
sexp_write_string(ctx, "#(", out);
for (i=0; i<SEXP_HEAP_VECTOR_DEPTH && i<(int)sexp_vector_length(x); i++) {
if (i>0)
sexp_write_char(ctx, ' ', out);
sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1);
}
if (i<(int)sexp_vector_length(x))
sexp_write_string(ctx, " ...", out);
sexp_write_char(ctx, ')', out);
} else {
print_name:
sexp_write_string(ctx, "#<", out);
sexp_write(ctx, sexp_object_type_name(ctx, x), out);
sexp_write_string(ctx, ">", out);
}
}
static sexp sexp_vector_nreverse (sexp ctx, sexp vec) {
int i, j;
sexp tmp, *data=sexp_vector_data(vec);
for (i=0, j=sexp_vector_length(vec)-1; i<j; i++, j--)
swap(tmp, data[i], data[j]);
return vec;
}
static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) {
sexp res;
int p = sexp_unbox_fixnum(k);
if (! sexp_opcodep(op))
return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
else if (! sexp_fixnump(k))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, k);
if (p > sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op))
p = sexp_opcode_num_args(op);
switch (p) {
case 0:
res = sexp_opcode_arg1_type(op);
break;
case 1:
res = sexp_opcode_arg2_type(op);
break;
default:
res = sexp_opcode_arg3_type(op);
if (res && sexp_vectorp(res)) {
if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2))
res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO));
else
res = sexp_type_by_index(ctx, SEXP_OBJECT);
}
break;
}
return sexp_translate_opcode_type(ctx, res);
}
static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq,
sexp less, sexp key) {
sexp_sint_t len;
sexp res, *data;
sexp_gc_var1(vec);
if (sexp_nullp(seq)) return seq;
sexp_gc_preserve1(ctx, vec);
vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq);
if (! sexp_vectorp(vec)) {
res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec);
} else {
data = sexp_vector_data(vec);
len = sexp_vector_length(vec);
if (sexp_not(key) && sexp_basic_comparator(less)) {
sexp_qsort(ctx, data, 0, len-1);
if (sexp_opcodep(less) && sexp_opcode_inverse(less))
sexp_vector_nreverse(ctx, vec);
res = vec;
} else if (! (sexp_procedurep(less) || sexp_opcodep(less))) {
res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less);
} else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) {
res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key);
} else {
res = sexp_qsort_less(ctx, data, 0, len-1, less, key);
}
}
if (sexp_pairp(seq) && ! sexp_exceptionp(res))
res = sexp_vector_copy_to_list(ctx, vec, seq);
sexp_gc_release1(ctx);
return res;
}
