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