diff options
Diffstat (limited to 's7.c')
| -rw-r--r-- | s7.c | 7098 |
1 files changed, 3850 insertions, 3248 deletions
@@ -420,8 +420,8 @@ #define __func__ __FUNCTION__ #endif -#define DISPLAY(Obj) string_value(s7_object_to_string(sc, Obj, false)) -#define DISPLAY_80(Obj) string_value(object_to_truncated_string(sc, Obj, 80)) +#define display(Obj) string_value(s7_object_to_string(sc, Obj, false)) +#define display_80(Obj) string_value(object_to_truncated_string(sc, Obj, 80)) typedef intptr_t opcode_t; @@ -548,7 +548,7 @@ typedef struct { s7_pointer (*read_name)(s7_scheme *sc, s7_pointer pt); /* internal get-next-name reader */ s7_pointer (*read_sharp)(s7_scheme *sc, s7_pointer pt); /* internal get-next-sharp-constant reader */ s7_pointer (*read_line)(s7_scheme *sc, s7_pointer pt, bool eol_case, bool copied); /* function to read a string up to \n */ - void (*display)(s7_scheme *sc, const char *s, s7_pointer pt); + void (*displayer)(s7_scheme *sc, const char *s, s7_pointer pt); void (*close_port)(s7_scheme *sc, s7_pointer p); /* close-in|output-port */ } port_functions; @@ -737,9 +737,9 @@ struct opt_info { int32_t slots; opt_type_t types[NUM_VUNIONS]; int32_t addrs[NUM_VUNIONS]; - s7_pointer vexpr; + s7_pointer expr; const char *func; - int32_t line; + int32_t line, loc; #endif }; @@ -1111,7 +1111,8 @@ struct s7_scheme { s7_int max_vector_length, max_string_length, max_list_length, max_vector_dimensions, max_format_length, max_port_data_size, rec_loc, rec_len; s7_pointer stacktrace_defaults; - s7_pointer rec_stack, rec_testp, rec_f1p, rec_f2p, rec_f3p, rec_f4p, rec_f5p, rec_f6p, rec_f7p, rec_f8p, rec_f9p, rec_resp, rec_slot1, rec_slot2, rec_slot3; + s7_pointer rec_stack, rec_testp, rec_f1p, rec_f2p, rec_f3p, rec_f4p, rec_f5p, rec_f6p, rec_f7p, rec_f8p, rec_f9p; + s7_pointer rec_resp, rec_slot1, rec_slot2, rec_slot3, rec_p1, rec_p2; s7_function rec_testf, rec_f1f, rec_f2f, rec_f3f, rec_f4f, rec_f5f, rec_f6f, rec_f7f, rec_f8f, rec_f9f, rec_resf, rec_call; s7_int (*rec_fi1)(opt_info *o); s7_int (*rec_fi2)(opt_info *o); @@ -1126,7 +1127,6 @@ struct s7_scheme { s7_i_ii_t rec_i_ii_f; s7_d_dd_t rec_d_dd_f; s7_pointer rec_val1, rec_val2; - int32_t rec_pc1, rec_pc2; int32_t float_format_precision; vdims_t *wrap_only; @@ -1281,7 +1281,7 @@ struct s7_scheme { #endif /* syntax symbols et al */ - s7_pointer else_symbol, lambda_symbol, lambda_star_symbol, let_symbol, quote_symbol, unquote_symbol, macroexpand_symbol, + s7_pointer else_symbol, lambda_symbol, lambda_star_symbol, let_symbol, quote_symbol, quasiquote_symbol, unquote_symbol, macroexpand_symbol, define_expansion_symbol, define_expansion_star_symbol, baffle_symbol, with_let_symbol, if_symbol, autoload_error_symbol, when_symbol, unless_symbol, begin_symbol, cond_symbol, case_symbol, and_symbol, or_symbol, do_symbol, define_symbol, define_star_symbol, define_constant_symbol, with_baffle_symbol, define_macro_symbol, @@ -1304,7 +1304,7 @@ struct s7_scheme { string_greater_2, string_less_2, symbol_to_string_uncopied, vector_ref_2, vector_ref_3, vector_set_3, vector_set_4, read_char_1, fv_ref_2, fv_ref_3, fv_set_3, fv_set_unchecked, iv_ref_2, iv_ref_2i, iv_ref_3, iv_set_3, bv_ref_2, bv_ref_3, bv_set_3, - list_0, list_1, list_2, list_3, list_set_i, hash_table_ref_2, hash_table_2, + list_0, list_1, list_2, list_3, list_set_i, hash_table_ref_2, hash_table_2, format_f, format_allg_no_column, format_just_control_string, format_as_objstr, memq_2, memq_3, memq_4, memq_any, tree_set_memq_syms, read_line_uncopied, simple_inlet, lint_let_ref, lint_let_set, geq_2, add_i_random, is_defined_in_rootlet; @@ -1359,25 +1359,8 @@ struct s7_scheme { heap_block_t *heap_blocks; }; -#if S7_DEBUGGING -static void reset_opts(s7_scheme *sc) -{ - int32_t i; - opt_info *o; - for (i = 0; i < 32; i++) - { - int32_t k; - o = sc->opts[i]; - o->slots = 0; - for (k = 0; k < NUM_VUNIONS; k++) - { - o->v[k].obj = NULL; - o->types[k] = OO_P; - } - } -} -#else -#define reset_opts(sc) +#if S7_DEBUGGING && (0) +static void gdb_break(void) {}; #endif static s7_scheme *cur_sc = NULL; /* intended for gdb (see gdbinit) */ @@ -1539,7 +1522,6 @@ static inline char *alloc_permanent_string(s7_scheme *sc, size_t len) #if S7_DEBUGGING permanent_string_len += ALLOC_STRING_SIZE; #endif - /* fprintf(stderr, "new heap: %ld lost\n", ALLOC_STRING_SIZE - sc->alloc_string_k); */ sc->alloc_string_cells = (char *)malloc(ALLOC_STRING_SIZE); sc->alloc_string_k = 0; next_k = len; @@ -2061,7 +2043,7 @@ static void init_types(void) /* this marks symbols that represent syntax objects, it should be in the second byte */ #define T_SIMPLE_ARG_DEFAULTS (1 << (TYPE_BITS + 2)) -#define lambda_has_simple_defaults(p) has_type_bit(T_Pair(p), T_SIMPLE_ARG_DEFAULTS) +#define lambda_has_simple_defaults(p) has_type_bit(T_Pair(closure_body(p)), T_SIMPLE_ARG_DEFAULTS) #define lambda_set_simple_defaults(p) set_type_bit(T_Pair(p), T_SIMPLE_ARG_DEFAULTS) /* are all lambda* default values simple? This is set on closure_body, so it doesn't mess up closure_is_ok_1 */ @@ -2160,8 +2142,12 @@ static void init_types(void) } #define set_local(Symbol) set_local_1(sc, Symbol, __func__, __LINE__) #else +#if S7_DEBUGGING +#define set_local(p) do {if (is_keyword(p)) {fprintf(stderr, "%s[%d]: set %s local\n", __func__, __LINE__, symbol_name(p)); if (sc->stop_at_error) abort();} typeflag(T_Sym(p)) = ((typeflag(p) | T_LOCAL) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC));} while (0) +#else #define set_local(p) typeflag(T_Sym(p)) = ((typeflag(p) | T_LOCAL) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC)) #endif +#endif #define T_HIGH_C T_LOCAL #define has_high_c(p) has_type_bit(T_Pair(p), T_HIGH_C) @@ -2342,10 +2328,6 @@ static void init_types(void) #define set_no_bool_opt(p) set_type_bit(T_Pair(p), T_NO_BOOL_OPT) #define no_bool_opt(p) has_type_bit(T_Pair(p), T_NO_BOOL_OPT) -#define T_DIRECT_OPT T_SAFE_STEPPER -#define set_direct_opt(p) set_type_bit(T_Pair(p), T_DIRECT_OPT) -#define has_direct_opt(p) has_type_bit(T_Pair(p), T_DIRECT_OPT) - #define T_INTEGER_KEYS T_SETTER #define set_has_integer_keys(p) set_type_bit(T_Pair(p), T_INTEGER_KEYS) #define has_integer_keys(p) has_type_bit(T_Pair(p), T_INTEGER_KEYS) @@ -2778,6 +2760,7 @@ static void init_types(void) #define fx_call(Sc, F) c_call(F)(Sc, car(F)) #define d_call(Sc, F) c_call(F)(Sc, cdr(F)) #endif +/* fx_call can affect the stack and sc->value */ #define car(p) (T_Pair(p))->object.cons.car #define set_car(p, Val) (T_Pair(p))->object.cons.car = T_Pos(Val) @@ -2820,6 +2803,10 @@ static void init_types(void) #define cddadr(p) cdr(cdr(car(cdr(p)))) #define cddaar(p) cdr(cdr(car(car(p)))) +#define cadaddr(p) car(cdr(car(cdr(cdr(p))))) +#define caddadr(p) car(cdr(cdr(car(cdr(p))))) +#define caddaddr(p) car(cdr(cdr(car(cdr(cdr(p)))))) + #if WITH_GCC /* slightly tricky because cons can be called recursively */ #define cons(Sc, A, B) ({s7_pointer _X_, _A_, _B_; _A_ = A; _B_ = B; new_cell(Sc, _X_, T_PAIR | T_SAFE_PROCEDURE); set_car(_X_, _A_); set_cdr(_X_, _B_); _X_;}) @@ -2859,7 +2846,6 @@ static void init_types(void) #endif #define optimize_op_match(P, Q) ((is_optimized(P)) && ((optimize_op(P) & 0xfffe) == (Q))) #define op_no_hop(P) (optimize_op(P) & 0xfffe) -#define clear_hop(P) set_optimize_op(P, op_no_hop(P)) #define clear_optimize_op(P) set_optimize_op(P, 0) #define set_safe_optimize_op(P, Q) do {set_optimized(P); set_optimize_op(P, Q);} while (0) #define set_unsafe_optimize_op(P, Q) do {set_unsafely_optimized(P); set_optimize_op(P, Q);} while (0) @@ -2933,6 +2919,7 @@ static void symbol_set_id(s7_pointer p, s7_int id) #define next_slot(p) T_Sln((T_Slt(p))->object.slt.nxt) #define slot_set_next(p, Val) (T_Slt(p))->object.slt.nxt = T_Sln(Val) #define slot_set_pending_value(p, Val) do {(T_Slt(p))->object.slt.pending_value = T_Pos(Val); slot_set_has_pending_value(p);} while (0) +#define slot_simply_set_pending_value(p, Val) (T_Slt(p))->object.slt.pending_value = T_Pos(Val) #if S7_DEBUGGING static s7_pointer slot_pending_value(s7_pointer p) {if (slot_has_pending_value(p)) return(p->object.slt.pending_value); fprintf(stderr, "slot: no pending value\n"); abort();} static s7_pointer slot_expression(s7_pointer p) {if (slot_has_expression(p)) return(p->object.slt.expr); fprintf(stderr, "slot: no expression\n"); abort();} @@ -2940,6 +2927,7 @@ static s7_pointer slot_expression(s7_pointer p) {if (slot_has_expression(p)) #define slot_pending_value(p) (T_Slt(p))->object.slt.pending_value #define slot_expression(p) (T_Slt(p))->object.slt.expr #endif +#define slot_pending_value_unchecked(p) (T_Slt(p))->object.slt.pending_value #define slot_set_expression(p, Val) do {(T_Slt(p))->object.slt.expr = T_Pos(Val); slot_set_has_expression(p);} while (0) #define slot_just_set_expression(p, Val) (T_Slt(p))->object.slt.expr = T_Pos(Val) #define slot_setter(p) T_Prc(T_Slt(p)->object.slt.expr) @@ -3135,7 +3123,7 @@ static s7_pointer slot_expression(s7_pointer p) {if (slot_has_expression(p)) #define port_read_character(p) port_port(p)->pf->read_character #define port_read_line(p) port_port(p)->pf->read_line -#define port_display(p) port_port(p)->pf->display +#define port_display(p) port_port(p)->pf->displayer #define port_write_character(p) port_port(p)->pf->write_character #define port_write_string(p) port_port(p)->pf->write_string #define port_read_semicolon(p) port_port(p)->pf->read_semicolon @@ -3408,8 +3396,10 @@ static s7_pointer make_permanent_integer_unchecked(s7_int i) return(p); } -#define NUM_SMALL_INTS 2048 -static s7_pointer small_ints[NUM_SMALL_INTS + 1]; +#ifndef NUM_SMALL_INTS + #define NUM_SMALL_INTS 8192 +#endif +static s7_pointer small_ints[NUM_SMALL_INTS]; #define small_int(Val) small_ints[Val] #define is_small(n) ((n & ~(NUM_SMALL_INTS - 1)) == 0) @@ -3420,8 +3410,8 @@ static void init_small_ints(void) const char *ones[10] = {"0", "1", "2", "3", "4", "5", "6", "7", "8", "9"}; s7_cell *cells; int32_t i; - cells = (s7_cell *)calloc((NUM_SMALL_INTS + 1), sizeof(s7_cell)); - for (i = 0; i <= NUM_SMALL_INTS; i++) + cells = (s7_cell *)calloc((NUM_SMALL_INTS), sizeof(s7_cell)); + for (i = 0; i < NUM_SMALL_INTS; i++) { s7_pointer p; small_ints[i] = &cells[i]; @@ -3775,7 +3765,6 @@ static s7_pointer object_to_truncated_string(s7_scheme *sc, s7_pointer p, s7_int static token_t token(s7_scheme *sc); static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indices); static void free_hash_table(s7_scheme *sc, s7_pointer table); -static s7_pointer g_cdr(s7_scheme *sc, s7_pointer args); static s7_pointer s7_length(s7_scheme *sc, s7_pointer lst); static inline s7_pointer symbol_to_slot(s7_scheme *sc, s7_pointer symbol); static inline s7_pointer make_simple_vector(s7_scheme *sc, s7_int len); @@ -3819,6 +3808,7 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj); #endif static s7_pointer find_method(s7_scheme *sc, s7_pointer env, s7_pointer symbol); +static s7_pointer find_method_with_let(s7_scheme *sc, s7_pointer env, s7_pointer symbol); static s7_pointer find_let(s7_scheme *sc, s7_pointer obj); static bool call_begin_hook(s7_scheme *sc); static s7_pointer default_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val); @@ -3862,10 +3852,8 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_SAFE_C_opDq, HOP_SAFE_C_opDq, OP_SAFE_C_opSq, HOP_SAFE_C_opSq, OP_SAFE_C_opSSq, HOP_SAFE_C_opSSq, OP_SAFE_C_opSCq, HOP_SAFE_C_opSCq, OP_SAFE_C_opCSq, HOP_SAFE_C_opCSq, OP_SAFE_C_S_opSq, HOP_SAFE_C_S_opSq, - OP_SAFE_C_C_opSCq, HOP_SAFE_C_C_opSCq, - OP_SAFE_C_S_opSCq, HOP_SAFE_C_S_opSCq, OP_SAFE_C_S_opCSq, HOP_SAFE_C_S_opCSq, - OP_SAFE_C_opSq_S, HOP_SAFE_C_opSq_S, - OP_SAFE_C_opSq_C, HOP_SAFE_C_opSq_C, + OP_SAFE_C_C_opSCq, HOP_SAFE_C_C_opSCq, OP_SAFE_C_S_opSCq, HOP_SAFE_C_S_opSCq, OP_SAFE_C_S_opCSq, HOP_SAFE_C_S_opCSq, + OP_SAFE_C_opSq_S, HOP_SAFE_C_opSq_S, OP_SAFE_C_opSq_C, HOP_SAFE_C_opSq_C, OP_SAFE_C_opSq_opSq, HOP_SAFE_C_opSq_opSq, OP_SAFE_C_S_opSSq, HOP_SAFE_C_S_opSSq, OP_SAFE_C_C_opSq, HOP_SAFE_C_C_opSq, OP_SAFE_C_C_opCSq, HOP_SAFE_C_C_opCSq, OP_SAFE_C_opCSq_C, HOP_SAFE_C_opCSq_C, OP_SAFE_C_S_opDq, HOP_SAFE_C_S_opDq, OP_SAFE_C_opSSq_C, HOP_SAFE_C_opSSq_C, OP_SAFE_C_C_opSSq, HOP_SAFE_C_C_opSSq, @@ -3873,16 +3861,14 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_SAFE_C_opSSq_opSSq, HOP_SAFE_C_opSSq_opSSq, OP_SAFE_C_opSSq_opSq, HOP_SAFE_C_opSSq_opSq, OP_SAFE_C_opSq_opSSq, HOP_SAFE_C_opSq_opSSq, - OP_SAFE_C_opSSq_S, HOP_SAFE_C_opSSq_S, - OP_SAFE_C_opCSq_S, HOP_SAFE_C_opCSq_S, - OP_SAFE_C_opSCq_C, HOP_SAFE_C_opSCq_C, + OP_SAFE_C_opSSq_S, HOP_SAFE_C_opSSq_S, OP_SAFE_C_opCSq_S, HOP_SAFE_C_opCSq_S, OP_SAFE_C_opSCq_C, HOP_SAFE_C_opSCq_C, OP_SAFE_C_S_op_opSq_Cq, HOP_SAFE_C_S_op_opSq_Cq, OP_SAFE_C_S_op_S_opSSqq, HOP_SAFE_C_S_op_S_opSSqq, OP_SAFE_C_S_op_S_opSqq, HOP_SAFE_C_S_op_S_opSqq, - OP_SAFE_C_op_opSSq_q_C, HOP_SAFE_C_op_opSSq_q_C, OP_SAFE_C_op_opSq_q_C, HOP_SAFE_C_op_opSq_q_C, - OP_SAFE_C_op_opSSq_q_S, HOP_SAFE_C_op_opSSq_q_S, + OP_SAFE_C_op_opSSqq_C, HOP_SAFE_C_op_opSSqq_C, OP_SAFE_C_op_opSqq_C, HOP_SAFE_C_op_opSqq_C, + OP_SAFE_C_op_opSSqq_S, HOP_SAFE_C_op_opSSqq_S, OP_SAFE_C_S_op_opSSq_opSSqq, HOP_SAFE_C_S_op_opSSq_opSSqq, OP_SAFE_C_op_opSSq_Sq_S, HOP_SAFE_C_op_opSSq_Sq_S, - OP_SAFE_C_op_opSq_q, HOP_SAFE_C_op_opSq_q, - OP_SAFE_C_op_S_opSq_q, HOP_SAFE_C_op_S_opSq_q, OP_SAFE_C_op_opSq_S_q, HOP_SAFE_C_op_opSq_S_q, + OP_SAFE_C_op_opSqq, HOP_SAFE_C_op_opSqq, OP_SAFE_C_op_opSq_Cq, HOP_SAFE_C_op_opSq_Cq, + OP_SAFE_C_op_S_opSqq, HOP_SAFE_C_op_S_opSqq, OP_SAFE_C_op_opSq_Sq, HOP_SAFE_C_op_opSq_Sq, OP_SAFE_C_opSq_CS, HOP_SAFE_C_opSq_CS, OP_SAFE_C_A, HOP_SAFE_C_A, OP_SAFE_C_AA, HOP_SAFE_C_AA, OP_SAFE_C_CA, HOP_SAFE_C_CA, OP_SAFE_C_AC, HOP_SAFE_C_AC, @@ -3903,16 +3889,16 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_CLOSURE_S, HOP_CLOSURE_S, OP_CLOSURE_S_P, HOP_CLOSURE_S_P, OP_SAFE_CLOSURE_S, HOP_SAFE_CLOSURE_S, OP_SAFE_CLOSURE_S_P, HOP_SAFE_CLOSURE_S_P, OP_SAFE_CLOSURE_S_A, HOP_SAFE_CLOSURE_S_A, - OP_SAFE_CLOSURE_S_TO_S, HOP_SAFE_CLOSURE_S_TO_S, OP_SAFE_CLOSURE_S_TO_SC, HOP_SAFE_CLOSURE_S_TO_SC, + OP_SAFE_CLOSURE_S_TO_S, HOP_SAFE_CLOSURE_S_TO_S, OP_SAFE_CLOSURE_S_TO_SC, HOP_SAFE_CLOSURE_S_TO_SC, OP_SAFE_CLOSURE_A_TO_SC, HOP_SAFE_CLOSURE_A_TO_SC, OP_CLOSURE_C, HOP_CLOSURE_C, OP_CLOSURE_C_P, HOP_CLOSURE_C_P, OP_SAFE_CLOSURE_C, HOP_SAFE_CLOSURE_C, OP_SAFE_CLOSURE_C_P, HOP_SAFE_CLOSURE_C_P, OP_SAFE_CLOSURE_C_A, HOP_SAFE_CLOSURE_C_A, - OP_SAFE_CLOSURE_ID_S, HOP_SAFE_CLOSURE_ID_S, OP_CLOSURE_A, HOP_CLOSURE_A, OP_CLOSURE_A_P, HOP_CLOSURE_A_P, OP_SAFE_CLOSURE_A, HOP_SAFE_CLOSURE_A, OP_SAFE_CLOSURE_A_P, HOP_SAFE_CLOSURE_A_P, OP_SAFE_CLOSURE_A_A, HOP_SAFE_CLOSURE_A_A, OP_CLOSURE_P, HOP_CLOSURE_P, OP_SAFE_CLOSURE_P, HOP_SAFE_CLOSURE_P, - OP_CLOSURE_AP, HOP_CLOSURE_AP, OP_CLOSURE_PA, HOP_CLOSURE_PA, - OP_SAFE_CLOSURE_AP, HOP_SAFE_CLOSURE_AP, OP_SAFE_CLOSURE_PA, HOP_SAFE_CLOSURE_PA, + OP_CLOSURE_AP, HOP_CLOSURE_AP, OP_CLOSURE_PA, HOP_CLOSURE_PA, OP_CLOSURE_PP, HOP_CLOSURE_PP, + OP_SAFE_CLOSURE_AP, HOP_SAFE_CLOSURE_AP, OP_SAFE_CLOSURE_PA, HOP_SAFE_CLOSURE_PA, OP_SAFE_CLOSURE_PP, HOP_SAFE_CLOSURE_PP, OP_CLOSURE_FA, HOP_CLOSURE_FA, + OP_SAFE_OR_UNSAFE_CLOSURE_3P, HOP_SAFE_OR_UNSAFE_CLOSURE_3P, OP_CLOSURE_SS, HOP_CLOSURE_SS, OP_CLOSURE_SS_P, HOP_CLOSURE_SS_P, OP_SAFE_CLOSURE_SS, HOP_SAFE_CLOSURE_SS, OP_SAFE_CLOSURE_SS_P, HOP_SAFE_CLOSURE_SS_P, OP_SAFE_CLOSURE_SS_A, HOP_SAFE_CLOSURE_SS_A, @@ -3930,12 +3916,15 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_CLOSURE_FX, HOP_CLOSURE_FX, OP_CLOSURE_ALL_S, HOP_CLOSURE_ALL_S, OP_CLOSURE_ANY_FX, HOP_CLOSURE_ANY_FX, OP_SAFE_CLOSURE_SA, HOP_SAFE_CLOSURE_SA, OP_SAFE_CLOSURE_SAA, HOP_SAFE_CLOSURE_SAA, OP_SAFE_CLOSURE_FX, HOP_SAFE_CLOSURE_FX, OP_SAFE_CLOSURE_3S, HOP_SAFE_CLOSURE_3S, OP_SAFE_CLOSURE_ALL_S, HOP_SAFE_CLOSURE_ALL_S, + OP_SAFE_CLOSURE_3S_A, HOP_SAFE_CLOSURE_3S_A, + OP_SAFE_CLOSURE_FP, HOP_SAFE_CLOSURE_FP, OP_CLOSURE_STAR_A, HOP_CLOSURE_STAR_A, OP_CLOSURE_STAR_FX, HOP_CLOSURE_STAR_FX, - OP_SAFE_CLOSURE_STAR_A, HOP_SAFE_CLOSURE_STAR_A, OP_SAFE_CLOSURE_STAR_AA, HOP_SAFE_CLOSURE_STAR_AA, + OP_SAFE_CLOSURE_STAR_A, HOP_SAFE_CLOSURE_STAR_A, OP_SAFE_CLOSURE_STAR_AA, HOP_SAFE_CLOSURE_STAR_AA, + OP_SAFE_CLOSURE_STAR_A1, HOP_SAFE_CLOSURE_STAR_A1, + OP_SAFE_CLOSURE_STAR_KA, HOP_SAFE_CLOSURE_STAR_KA, OP_CLOSURE_STAR_KA, HOP_CLOSURE_STAR_KA, OP_SAFE_CLOSURE_STAR_FX, HOP_SAFE_CLOSURE_STAR_FX, OP_SAFE_CLOSURE_STAR_FX_0, HOP_SAFE_CLOSURE_STAR_FX_0, OP_SAFE_CLOSURE_STAR_FX_1, HOP_SAFE_CLOSURE_STAR_FX_1, OP_SAFE_CLOSURE_STAR_FX_2, HOP_SAFE_CLOSURE_STAR_FX_2, - OP_SAFE_CLOSURE_FP, HOP_SAFE_CLOSURE_FP, /* these can't be embedded, and have to be the last thing called */ OP_C_FX, HOP_C_FX, OP_CALL_WITH_EXIT, HOP_CALL_WITH_EXIT, OP_CALL_WITH_EXIT_P, HOP_CALL_WITH_EXIT_P, @@ -3974,6 +3963,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_LETREC, OP_LETREC1, OP_LETREC_STAR, OP_LETREC_STAR1, OP_LET_TEMPORARILY, OP_LET_TEMP_UNCHECKED, OP_LET_TEMP_INIT1, OP_LET_TEMP_INIT2, OP_LET_TEMP_DONE, OP_LET_TEMP_DONE1, OP_LET_TEMP_S7, OP_LET_TEMP_FX, OP_LET_TEMP_FX_1, OP_LET_TEMP_SETTER, OP_LET_TEMP_UNWIND, OP_LET_TEMP_S7_UNWIND, OP_LET_TEMP_SETTER_UNWIND, + OP_LET_TEMP_A_A, OP_COND, OP_COND1, OP_FEED_TO_1, OP_COND_SIMPLE, OP_COND1_SIMPLE, OP_COND_SIMPLE_P, OP_COND1_SIMPLE_P, OP_AND, OP_OR, OP_DEFINE_MACRO, OP_DEFINE_MACRO_STAR, OP_DEFINE_EXPANSION, OP_DEFINE_EXPANSION_STAR, @@ -4015,7 +4005,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_LET_ONE_OLD, OP_LET_ONE_NEW, OP_LET_ONE_P_OLD, OP_LET_ONE_P_NEW, OP_LET_ONE_OLD_1, OP_LET_ONE_NEW_1, OP_LET_ONE_P_OLD_1, OP_LET_ONE_P_NEW_1, OP_LET_A_OLD, OP_LET_A_NEW, OP_LET_A_P_OLD, OP_LET_A_P_NEW, OP_LET_A_A_OLD, OP_LET_A_A_NEW, OP_LET_A_FX_OLD, OP_LET_A_FX_NEW, OP_LET_A_OLD_2, OP_LET_A_NEW_2, - OP_LET_STAR_FX_OLD, OP_LET_STAR_FX_NEW, OP_LET_STAR_FX_A_OLD, OP_LET_STAR_FX_A_NEW, + OP_LET_STAR_FX, OP_LET_STAR_FX_A, OP_CASE_A_E_S, OP_CASE_A_I_S, OP_CASE_A_G_S, OP_CASE_A_E_G, OP_CASE_A_G_G, OP_CASE_A_S_S, OP_CASE_A_S_G, OP_CASE_S_E_S, OP_CASE_S_I_S, OP_CASE_S_G_S, OP_CASE_S_E_G, OP_CASE_S_G_G, OP_CASE_S_S_S, OP_CASE_S_S_G, @@ -4028,7 +4018,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_COND_FEED, OP_COND_FEED_1, OP_WHEN_S, OP_WHEN_A, OP_WHEN_P, OP_WHEN_AND_AP, OP_WHEN_AND_2, OP_WHEN_AND_3, OP_UNLESS_S, OP_UNLESS_A, OP_UNLESS_P, - OP_IF_A_CC, OP_IF_A_A, OP_IF_A_AA, OP_IF_NOT_A_A, OP_IF_NOT_A_AA, + OP_IF_A_CC, OP_IF_A_A, OP_IF_A_AA, OP_IF_S_AA, OP_IF_AND2_SA, OP_IF_NOT_A_A, OP_IF_NOT_A_AA, OP_IF_A_A_P, OP_IF_S_P_A, OP_IF_IS_TYPE_S_P_A, OP_IF_S_P, OP_IF_S_P_P, OP_IF_S_R, OP_IF_S_N, OP_IF_S_N_N, @@ -4053,21 +4043,24 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_SAFE_C_SP_1, OP_SAFE_C_SP_MV, OP_SAFE_CONS_SP_1, OP_SAFE_ADD_SP_1, OP_SAFE_MULTIPLY_SP_1, OP_SAFE_SUBTRACT_SP_1, OP_SAFE_C_PS_1, OP_SAFE_C_PC_1, OP_SAFE_C_PS_MV, OP_SAFE_C_PC_MV, OP_EVAL_MACRO_MV, OP_MACROEXPAND_1, OP_APPLY_LAMBDA, - OP_SAFE_CLOSURE_P_1, OP_CLOSURE_P_1, OP_SAFE_CLOSURE_AP_1, OP_SAFE_CLOSURE_PA_1, OP_SAFE_CLOSURE_FP_1, OP_SAFE_CLOSURE_FP_MV_1, + OP_SAFE_CLOSURE_P_1, OP_CLOSURE_P_1, + OP_SAFE_CLOSURE_AP_1, OP_SAFE_CLOSURE_PA_1, OP_SAFE_CLOSURE_PP_1, OP_SAFE_CLOSURE_FP_1, OP_SAFE_CLOSURE_FP_MV_1, OP_INCREMENT_SP_1, OP_INCREMENT_SP_MV, OP_SAFE_C_FP_1, OP_SAFE_C_FP_MV_1, OP_SAFE_C_SSP_1, OP_SAFE_C_SSP_MV_1, OP_C_P_1, OP_C_P_MV, OP_C_AP_1, OP_C_AP_MV, OP_NOT_P_1, OP_SAFE_C_FP_2, - OP_CLOSURE_AP_1, OP_CLOSURE_PA_1, - OP_CLOSURE_P_MV, OP_CLOSURE_AP_MV, OP_CLOSURE_PA_MV, + OP_CLOSURE_AP_1, OP_CLOSURE_PA_1, OP_CLOSURE_PP_1, OP_SAFE_C_PA_1, OP_SAFE_C_PA_MV, OP_SAFE_CLOSURE_FP_2, + OP_SAFE_OR_UNSAFE_CLOSURE_3P_1, OP_SAFE_OR_UNSAFE_CLOSURE_3P_2, OP_SAFE_OR_UNSAFE_CLOSURE_3P_3, OP_SET_WITH_LET_1, OP_SET_WITH_LET_2, - OP_TC_AND_A_OR_A_LA, OP_TC_OR_A_AND_A_LA, OP_TC_AND_A_OR_A_LAA, OP_TC_OR_A_AND_A_LAA, OP_TC_OR_A_A_AND_A_A_LA, OP_TC_OR_A_AND_A_A_L3A, + OP_TC_AND_A_OR_A_LA, OP_TC_OR_A_AND_A_LA, OP_TC_AND_A_OR_A_LAA, OP_TC_OR_A_AND_A_LAA, OP_TC_OR_A_A_AND_A_A_LA, + OP_TC_OR_A_AND_A_A_L3A, OP_TC_AND_A_OR_A_A_LA, OP_TC_LET_WHEN_LAA, OP_TC_LET_UNLESS_LAA, OP_TC_COND_A_Z_A_Z_LAA, OP_TC_COND_A_Z_A_LAA_LAA, OP_TC_LET_COND, - OP_TC_IF_A_Z_LA, OP_TC_IF_A_Z_LAA, OP_TC_IF_A_LA_Z, OP_TC_IF_A_LAA_Z, OP_TC_IF_A_T_AND_A_A_L3A, - OP_TC_IF_A_Z_IF_A_Z_LA, OP_TC_IF_A_Z_IF_A_LA_Z, OP_TC_IF_A_Z_IF_A_Z_LAA, OP_TC_IF_A_Z_IF_A_LAA_Z, + OP_TC_IF_A_Z_LA, OP_TC_IF_A_Z_LAA, OP_TC_IF_A_Z_L3A, OP_TC_IF_A_L3A_Z, OP_TC_IF_A_LA_Z, OP_TC_IF_A_LAA_Z, OP_TC_IF_A_T_AND_A_A_L3A, + OP_TC_IF_A_Z_IF_A_Z_LA, OP_TC_IF_A_Z_IF_A_LA_Z, OP_TC_IF_A_Z_IF_A_Z_LAA, OP_TC_COND_A_Z_A_Z_LA, + OP_TC_IF_A_Z_IF_A_LAA_Z, OP_TC_IF_A_Z_IF_A_L3A_L3A, OP_TC_LET_IF_A_Z_LAA, OP_TC_CASE_LA, @@ -4075,7 +4068,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_RECUR_IF_A_A_opLA_LAq, OP_RECUR_IF_A_opLA_LAq_A, OP_RECUR_IF_A_A_opA_LA_LAq, OP_RECUR_IF_A_opA_LA_LAq_A, OP_RECUR_IF_A_A_opLA_LA_LAq, - OP_RECUR_IF_A_A_opA_LAAq, OP_RECUR_IF_A_opA_LAAq_A, + OP_RECUR_IF_A_A_opA_LAAq, OP_RECUR_IF_A_opA_LAAq_A, OP_RECUR_IF_A_A_opA_L3Aq, OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq, OP_RECUR_IF_A_A_AND_A_LAA_LAA, OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq, /* same as cond case below */ @@ -4086,7 +4079,6 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot NUM_OPS}; #define is_tc_op(Op) ((Op >= OP_TC_AND_A_OR_A_LA) && (Op <= OP_TC_CASE_LA)) -#define is_rec_op(Op) ((Op >= OP_RECUR_IF_A_A_opA_LAq) && (Op <= OP_RECUR_COND_A_A_A_LAA_opA_LAAq)) typedef enum{E_C_P, E_C_PP, E_C_CP, E_C_SP, E_C_PC, E_C_PS} combine_op_t; @@ -4103,10 +4095,8 @@ static const char* op_names[NUM_OPS] = "safe_c_opdq", "h_safe_c_opdq", "safe_c_opsq", "h_safe_c_opsq", "safe_c_opssq", "h_safe_c_opssq", "safe_c_opscq", "h_safe_c_opscq", "safe_c_opcsq", "h_safe_c_opcsq", "safe_c_s_opsq", "h_safe_c_s_opsq", - "safe_c_c_opscq", "h_safe_c_c_opscq", - "safe_c_s_opscq", "h_safe_c_s_opscq", "safe_c_s_opcsq", "h_safe_c_s_opcsq", - "safe_c_opsq_s", "h_safe_c_opsq_s", - "safe_c_opsq_c", "h_safe_c_opsq_c", + "safe_c_c_opscq", "h_safe_c_c_opscq", "safe_c_s_opscq", "h_safe_c_s_opscq", "safe_c_s_opcsq", "h_safe_c_s_opcsq", + "safe_c_opsq_s", "h_safe_c_opsq_s", "safe_c_opsq_c", "h_safe_c_opsq_c", "safe_c_opsq_opsq", "h_safe_c_opsq_opsq", "safe_c_s_opssq", "h_safe_c_s_opssq", "safe_c_c_opsq", "h_safe_c_c_opsq", "safe_c_c_opcsq", "h_safe_c_c_opcsq", "safe_c_opcsq_c", "h_safe_c_opcsq_c", "safe_c_s_opdq", "h_safe_c_s_opdq", "safe_c_opssq_c", "h_safe_c_opssq_c", "safe_c_c_opssq", "h_safe_c_c_opssq", @@ -4114,16 +4104,14 @@ static const char* op_names[NUM_OPS] = "safe_c_opssq_opssq", "h_safe_c_opssq_opssq", "safe_c_opssq_opsq", "h_safe_c_opssq_opsq", "safe_c_opsq_opssq", "h_safe_c_opsq_opssq", - "safe_c_opssq_s", "h_safe_c_opssq_s", - "safe_c_opcsq_s", "h_safe_c_opcsq_s", - "safe_c_opscq_c", "h_safe_c_opscq_c", + "safe_c_opssq_s", "h_safe_c_opssq_s", "safe_c_opcsq_s", "h_safe_c_opcsq_s", "safe_c_opscq_c", "h_safe_c_opscq_c", "safe_c_s_op_opsq_cq", "h_safe_c_s_op_opsq_cq", "safe_c_s_op_s_opssqq", "h_safe_c_s_op_s_opssqq", "safe_c_s_op_s_opsqq", "h_safe_c_s_op_s_opsqq", - "safe_c_op_opssq_q_c", "h_safe_c_op_opssq_q_c", "safe_c_op_opsq_q_c", "h_safe_c_op_opsq_q_c", - "safe_c_op_opssq_q_s", "h_safe_c_op_opssq_q_s", + "safe_c_op_opssqq_c", "h_safe_c_op_opssqq_c", "safe_c_op_opsqq_c", "h_safe_c_op_opsqq_c", + "safe_c_op_opssqq_s", "h_safe_c_op_opssqq_s", "safe_c_s_op_opssq_opssqq", "h_safe_c_s_op_opssq_opssqq", "safe_c_opssq_sq_s", "h_safe_c_opssq_sq_s", - "safe_c_op_opsq_q", "h_safe_c_op_opsq_q", - "safe_c_op_s_opsq_q", "h_safe_c_op_s_opsq_q", "safe_c_op_opsq_s_q", "h_safe_c_op_opsq_s_q", + "safe_c_op_opsqq", "h_safe_c_op_opsqq", "safe_c_op_opsq_cq", "h_safe_c_op_opsq_cq", + "safe_c_op_s_opsqq", "h_safe_c_op_s_opsqq", "safe_c_op_opsq_sq", "h_safe_c_op_opsq_sq", "safe_c_opsq_cs", "h_safe_c_opsq_cs", "safe_c_a", "h_safe_c_a", "safe_c_aa", "h_safe_c_aa", "safe_c_ca", "h_safe_c_ca", "safe_c_ac", "h_safe_c_ac", @@ -4143,16 +4131,16 @@ static const char* op_names[NUM_OPS] = "closure_s", "h_closure_s", "closure_s_p", "h_closure_s_p", "safe_closure_s", "h_safe_closure_s", "safe_closure_s_p", "h_safe_closure_s_p", "safe_closure_s_a", "h_safe_closure_s_a", - "safe_closure_s_to_s", "h_safe_closure_s_to_s", "safe_closure_s_to_sc", "h_safe_closure_s_to_sc", + "safe_closure_s_to_s", "h_safe_closure_s_to_s", "safe_closure_s_to_sc", "h_safe_closure_s_to_sc", "safe_closure_a_to_sc", "h_safe_closure_a_to_sc", "closure_c", "h_closure_c", "closure_c_p", "h_closure_c_p", "safe_closure_c", "h_safe_closure_c", "safe_closure_c_p", "h_safe_closure_c_p", "safe_closure_c_a", "h_safe_closure_c_a", - "safe_closure_id_s", "h_safe_closure_id_s", "closure_a", "h_closure_a", "closure_a_p", "h_closure_a_p", "safe_closure_a", "h_safe_closure_a", "safe_closure_a_p", "h_safe_closure_a_p", "safe_closure_a_a", "h_safe_closure_a_a", "closure_p", "h_closure_p", "safe_closure_p", "h_safe_closure_p", - "closure_ap", "h_closure_ap", "closure_pa", "h_closure_pa", - "safe_closure_ap", "h_safe_closure_ap", "safe_closure_pa", "h_safe_closure_pa", + "closure_ap", "h_closure_ap", "closure_pa", "h_closure_pa", "closure_pp", "h_closure_pp", + "safe_closure_ap", "h_safe_closure_ap", "safe_closure_pa", "h_safe_closure_pa", "safe_closure_pp", "h_safe_closure_pp", "closure_fa", "h_closure_fa", + "safe_or_unsafe_closure_3p", "h_safe_or_unsafe_closure_3p", "closure_ss", "h_closure_ss", "closure_ss_p", "h_closure_ss_p", "safe_closure_ss", "h_safe_closure_ss", "safe_closure_ss_p", "h_safe_closure_ss_p", "safe_closure_ss_a", "h_safe_closure_ss_a", @@ -4170,12 +4158,15 @@ static const char* op_names[NUM_OPS] = "safe_closure_sa", "h_safe_closure_sa", "safe_closure_saa", "h_safe_closure_saa", "safe_closure_fx", "h_safe_closure_fx", "safe_closure_3s", "h_safe_closure_3s", "safe_closure_all_s", "h_safe_closure_all_s", + "safe_closure_3s_a", "h_safe_closure_3s_a", + "safe_closure_fp", "h_safe_closure_fp", "closure*_a", "h_closure*_a", "closure*_fx", "h_closure*_fx", - "safe_closure*_a", "h_safe_closure*_a", "safe_closure*_aa", "h_safe_closure*_aa", + "safe_closure*_a", "h_safe_closure*_a", "safe_closure*_aa", "h_safe_closure*_aa", + "safe_closure*_a1", "h_safe_closure*_a1", + "safe_closure*_ka", "h_safe_closure*_ka", "closure*_ka", "h_closure*_ka", "safe_closure*_fx", "h_safe_closure*_fx", "safe_closure*_fx_0", "h_safe_closure*_fx_0", "safe_closure*_fx_1", "h_safe_closure*_fx_1", "safe_closure*_fx_2", "h_safe_closure*_fx_2", - "safe_closure_fp", "h_safe_closure_fp", "c_fx", "h_c_fx", "call_with_exit", "h_call_with_exit", "call_with_exit_p", "h_call_with_exit_p", "c_catch", "h_c_catch", "c_catch_all", "h_c_catch_all", "c_catch_all_p", "h_c_catch_all_p", "c_catch_all_fx", "h_c_catch_all_fx", @@ -4212,6 +4203,7 @@ static const char* op_names[NUM_OPS] = "letrec", "letrec1", "letrec*", "letrec*1", "let_temporarily", "let_temp_unchecked", "let_temp_init1", "let_temp_init2", "let_temp_done", "let_temp_done1", "let_temp_s7", "let_temp_fx", "let_temp_fx_1", "let_temp_setter", "let_temp_unwind", "let_temp_s7_unwind", "let_temp_setter_unwind", + "let_temp_a_a", "cond", "cond1", "feed_to_1", "cond_simple", "cond1_simple", "cond_simple_p", "cond1_simple_p", "and", "or", "define_macro", "define_macro*", "define_expansion", "define_expansion*", @@ -4250,7 +4242,7 @@ static const char* op_names[NUM_OPS] = "let_one_old", "let_one_new", "let_one_p_old", "let_one_p_new", "let_one_old_1", "let_one_new_1", "let_one_p_old_1", "let_one_p_new_1", "let_a_old", "let_a_new", "let_a_p_old", "let_a_p_new", "let_a_a_old", "let_a_a_new", "let_a_fx_old", "let_a_fx_new", "let_a_old_2", "let_a_new_2", - "let*_fx_old", "let*_fx_new", "let*_fx_a_old", "let*_fx_a_new", + "let*_fx", "let*_fx_a", "case_a_e_s", "case_a_i_s", "case_a_g_s", "case_a_e_g", "case_a_g_g", "case_a_s_s", "case_a_s_g", "case_s_e_s", "case_s_i_s", "case_s_g_s", "case_s_e_g", "case_s_g_g", "case_s_s_s", "case_s_s_g", @@ -4263,7 +4255,7 @@ static const char* op_names[NUM_OPS] = "cond_feed", "cond_feed_1", "when_s", "when_a", "when_p", "when_and_ap", "when_and_2", "when_and_3", "unless_s", "unless_a", "unless_p", - "if_a_cc", "if_a_a", "if_a_aa", "if_not_a_a", "if_not_a_aa", + "if_a_cc", "if_a_a", "if_a_aa", "if_s_aa", "if_and2_sa", "if_not_a_a", "if_not_a_aa", "if_a_a_p", "if_s_p_a", "if_is_type_s_p_a", "if_s_p", "if_s_p_p", "if_s_r", "if_s_n", "if_s_n_n", @@ -4288,21 +4280,24 @@ static const char* op_names[NUM_OPS] = "safe_c_sp_1", "safe_c_sp_mv", "safe_cons_sp_1", "safe_add_sp_1", "safe_multiply_sp_1", "safe_subtract_sp_1", "safe_c_ps_1", "safe_c_pc_1", "safe_c_ps_mv", "safe_c_pc_mv", "eval_macro_mv", "macroexpand_1", "apply_lambda", - "safe_closure_p_1", "closure_p_1", "safe_closure_ap_1", "safe_closure_pa_1", "safe_closure_fp_1", "safe_closure_fp_mv_1", + "safe_closure_p_1", "closure_p_1", + "safe_closure_ap_1", "safe_closure_pa_1", "safe_closure_pp_1", "safe_closure_fp_1", "safe_closure_fp_mv_1", "increment_sp_1", "increment_sp_mv", "safe_c_fp_1", "safe_c_fp_mv_1", "safe_c_ssp_1", "safe_c_ssp_mv_1", "c_p_1", "c_p_mv", "c_ap_1", "c_ap_mv", "not_1", "safe_c_fp_2", - "closure_ap_1", "closure_pa_1", - "closure_p_mv", "closure_ap_mv", "closure_pa_mv", + "closure_ap_1", "closure_pa_1", "closure_pp_1", "safe_c_pa_1", "safe_c_pa_mv", "safe_closure_fp_2", + "safe_or_unsafe_closure_3p_1", "safe_or_unsafe_closure_3p_2", "safe_or_unsafe_closure_3p_3", "set_with_let_1", "set_with_let_2", - "tc_and_a_or_a_la", "tc_or_a_and_a_la", "tc_and_a_or_a_laa", "tc_or_a_and_a_laa", "tc_or_a_a_and_a_a_la", "tc_or_a_and_a_a_l3a", + "tc_and_a_or_a_la", "tc_or_a_and_a_la", "tc_and_a_or_a_laa", "tc_or_a_and_a_laa", "tc_or_a_a_and_a_a_la", + "tc_or_a_and_a_a_l3a", "tc_and_a_or_a_a_la", "tc_let_when_laa", "tc_let_unless_laa", "tc_cond_a_z_a_z_laa", "tc_cond_a_z_a_laa_laa", "tc_let_cond", - "tc_if_a_z_la", "tc_if_a_z_laa", "tc_if_a_la_z", "tc_if_a_laa_z", "tc_if_a_t_and_a_a_l3a", - "tc_if_a_z_if_a_z_la", "tc_if_a_z_if_a_la_z", "tc_if_a_z_if_a_z_laa", "tc_if_a_z_if_a_laa_z", + "tc_if_a_z_la", "tc_if_a_z_laa", "tc_if_a_z_l3a", "tc_if_a_l3a_z", "tc_if_a_la_z", "tc_if_a_laa_z", "tc_if_a_t_and_a_a_l3a", + "tc_if_a_z_if_a_z_la", "tc_if_a_z_if_a_la_z", "tc_if_a_z_if_a_z_laa", "tc_cond_a_z_a_z_la", + "tc_if_a_z_if_a_laa_z", "tc_if_a_z_if_a_l3a_l3a", "tc_let_if_a_z_laa", "tc_case_la", @@ -4310,7 +4305,7 @@ static const char* op_names[NUM_OPS] = "recur_if_a_a_opla_laq", "recur_if_a_opla_laq_a", "recur_if_a_a_opa_la_laq", "recur_if_a_opa_la_laq_a", "recur_if_a_a_opla_la_laq", - "recur_if_a_a_opa_laaq", "recur_if_a_opa_laaq_a", + "recur_if_a_a_opa_laaq", "recur_if_a_opa_laaq_a", "recur_if_a_a_opa_l3aq", "recur_if_a_a_lopl3a_l3a_l3aq", "recur_if_a_a_and_a_laa_laa", "recur_if_a_a_if_a_laa_opa_laaq", @@ -4336,14 +4331,6 @@ static bool is_h_optimized(s7_pointer p) (optimize_op(p) > OP_GC_PROTECT)); } -static bool is_not_h_optimized(s7_pointer p) -{ - return((is_optimized(p)) && - ((optimize_op(p) & 1) == 0) && - (optimize_op(p) < OP_S) && - (optimize_op(p) > OP_GC_PROTECT)); -} - /* -------- */ static s7_pointer set_elist_1(s7_scheme *sc, s7_pointer x1) { @@ -4461,7 +4448,7 @@ static int32_t position_of(s7_pointer p, s7_pointer args) s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method) { if (has_active_methods(sc, obj)) - return(find_method(sc, find_let(sc, obj), method)); + return(find_method_with_let(sc, obj, method)); return(sc->undefined); } @@ -4474,7 +4461,7 @@ static inline s7_pointer copy_list(s7_scheme *sc, s7_pointer lst); { \ s7_pointer func; \ if ((has_active_methods(sc, Obj)) && \ - ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->undefined)) \ + ((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \ return(s7_apply_function(Sc, func, copy_list(Sc, Args))); \ } @@ -4482,7 +4469,7 @@ static inline s7_pointer copy_list(s7_scheme *sc, s7_pointer lst); { \ s7_pointer func; \ if ((has_active_methods(sc, Obj)) && \ - ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->undefined)) \ + ((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \ return(s7_apply_function(Sc, func, Args)); \ } @@ -4490,7 +4477,7 @@ static inline s7_pointer copy_list(s7_scheme *sc, s7_pointer lst); { \ s7_pointer func; \ if ((has_active_methods(sc, Obj)) && \ - ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->undefined)) \ + ((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \ {unstack(Sc); return(s7_apply_function(Sc, func, copy_list(Sc, Args)));} \ } @@ -4499,7 +4486,7 @@ static inline s7_pointer copy_list(s7_scheme *sc, s7_pointer lst); static s7_pointer apply_boolean_method(s7_scheme *sc, s7_pointer obj, s7_pointer method) { s7_pointer func; - func = find_method(sc, find_let(sc, obj), method); + func = find_method_with_let(sc, obj, method); if (func == sc->undefined) return(sc->F); return(s7_apply_function(sc, func, list_1(sc, obj))); } @@ -4615,7 +4602,7 @@ static s7_pointer g_is_unspecified(s7_scheme *sc, s7_pointer args) /* -------------------------------- eof-object? -------------------------------- */ -s7_pointer eof_object = NULL; +s7_pointer eof_object = NULL; /* #<eof> -- a character, an entry in the chars array, so not a part of sc */ s7_pointer s7_eof_object(s7_scheme *sc) {return(eof_object);} @@ -5197,7 +5184,7 @@ static void add_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter) s7_int i; #if S7_DEBUGGING if ((!is_any_closure(setter)) && (!is_any_macro(setter))) - fprintf(stderr, "add_setter: %s %d?\n", DISPLAY(setter), type(setter)); + fprintf(stderr, "add_setter: %s %d?\n", display(setter), type(setter)); #endif for (i = 0; i < sc->setters_loc; i++) { @@ -5813,6 +5800,9 @@ static int64_t gc(s7_scheme *sc) gc_mark(car(sc->qlist_3)); gc_mark(cadr(sc->qlist_3)); gc_mark(caddr(sc->qlist_3)); gc_mark(car(sc->u1_1)); + gc_mark(sc->rec_p1); + gc_mark(sc->rec_p2); + { s7_pointer p; for (p = sc->wrong_type_arg_info; is_pair(p); p = cdr(p)) gc_mark(car(p)); @@ -5890,8 +5880,8 @@ static int64_t gc(s7_scheme *sc) heap_top = (s7_pointer *)(sc->heap + sc->heap_size); #if S7_DEBUGGING -#define gc_call(P, Tp) \ - p = (*tp++); \ + #define gc_call(Tp) \ + p = (*Tp++); \ if (is_marked(T_Any(p))) \ clear_mark(p); \ else \ @@ -5905,16 +5895,16 @@ static int64_t gc(s7_scheme *sc) (*fp++) = p; \ }} #else - #define gc_call(P, Tp) p = (*tp++); if (is_marked(p)) clear_mark(p); else {if (!is_free_and_clear(p)) {clear_type(p); (*fp++) = p;}} + #define gc_call(Tp) p = (*Tp++); if (is_marked(p)) clear_mark(p); else {if (!is_free_and_clear(p)) {clear_type(p); (*fp++) = p;}} #endif while (tp < heap_top) /* != here or ^ makes no difference */ { s7_pointer p; - LOOP_8(gc_call(p, tp)); - LOOP_8(gc_call(p, tp)); - LOOP_8(gc_call(p, tp)); - LOOP_8(gc_call(p, tp)); + LOOP_8(gc_call(tp)); + LOOP_8(gc_call(tp)); + LOOP_8(gc_call(tp)); + LOOP_8(gc_call(tp)); } sc->free_heap_top = fp; @@ -6453,6 +6443,8 @@ static void push_stack(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer c #define push_stack_no_let(Sc, Op, Args, Code) push_stack(Sc, Op, Args, Code) #define push_stack_op(Sc, Op) push_stack(Sc, Op, sc->unused, sc->unused) #define push_stack_op_let(Sc, Op) push_stack(Sc, Op, sc->unused, sc->unused) +#define push_stack_direct(Sc, Op, Args, Code) push_stack(Sc, Op, Args, Code) +#define push_stack_no_args_direct(Sc, Op, Code) push_stack(Sc, Op, sc->unused, Code) /* in the non-debugging case, the sc->unused's here are not set, so we can (later) pop free cells */ #else @@ -6460,6 +6452,9 @@ static void push_stack(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer c #define pop_stack(Sc) do {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 4 * sizeof(s7_pointer));} while (0) #define pop_stack_no_op(Sc) {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 3 * sizeof(s7_pointer));} while (0) +/* TODO: these should protect against gc_protect_direct or some other push_stack happening in fx_* as an argument -- + * the stack pointer changes, and the push is in consistent + */ #define push_stack(Sc, Op, Args, Code) \ do { \ Sc->stack_end[0] = Code; \ @@ -6469,6 +6464,13 @@ static void push_stack(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer c Sc->stack_end += 4; \ } while (0) +#define push_stack_direct(Sc, Op, Args, Code) \ + do { \ + memcpy((void *)(Sc->stack_end), (void *)Sc, 3 * sizeof(s7_pointer)); \ + Sc->stack_end[3] = (s7_pointer)(Op); \ + Sc->stack_end += 4; \ + } while (0) + #define push_stack_no_code(Sc, Op, Args) \ do { \ Sc->stack_end[1] = Sc->envir; \ @@ -6492,6 +6494,13 @@ static void push_stack(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer c Sc->stack_end += 4; \ } while (0) +#define push_stack_no_args_direct(Sc, Op, Code) \ + do { \ + memcpy((void *)(Sc->stack_end), (void *)Sc, 2 * sizeof(s7_pointer)); \ + Sc->stack_end[3] = (s7_pointer)(Op); \ + Sc->stack_end += 4; \ + } while (0) + #define push_stack_no_let(Sc, Op, Args, Code) \ do { \ Sc->stack_end[0] = Code; \ @@ -6582,7 +6591,7 @@ static void resize_stack(s7_scheme *sc) if (show_stack_stats(sc)) { - s7_warn(sc, 128, "stack grows to %u, %s\n", new_size, DISPLAY_80(sc->code)); + s7_warn(sc, 128, "stack grows to %u, %s\n", new_size, display_80(sc->code)); s7_show_let(sc); } } @@ -7350,7 +7359,6 @@ static s7_pointer old_frame_with_three_slots(s7_scheme *sc, s7_pointer env, s7_p return(env); } - #if S7_DEBUGGING static s7_int permanent_slots = 0; #endif @@ -7397,21 +7405,6 @@ static s7_pointer make_permanent_let(s7_scheme *sc, s7_pointer vars) return(frame); } -static s7_pointer activate_permanent_let_star(s7_scheme *sc, s7_pointer frame, s7_pointer vars) -{ - s7_pointer slot, var; - let_id(frame) = ++sc->let_number; - set_outlet(frame, sc->envir); - sc->envir = frame; - for (var = vars, slot = let_slots(frame); is_pair(var); var = cdr(var), slot = next_slot(slot)) - { - slot_set_value(slot, fx_call(sc, cdar(var))); - symbol_set_local(caar(var), sc->let_number, slot); - } - return(frame); -} - - static s7_pointer find_let(s7_scheme *sc, s7_pointer obj) { if (is_let(obj)) return(obj); @@ -7501,6 +7494,11 @@ static s7_pointer find_method(s7_scheme *sc, s7_pointer env, s7_pointer symbol) return(sc->undefined); } +static s7_pointer find_method_with_let(s7_scheme *sc, s7_pointer env, s7_pointer symbol) +{ + return(find_method(sc, find_let(sc, env), symbol)); +} + static s7_int s7_let_length(void); static s7_int let_length(s7_scheme *sc, s7_pointer e) @@ -7693,7 +7691,6 @@ s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_poi static s7_pointer make_slot(s7_scheme *sc, s7_pointer variable, s7_pointer value) { - /* this is for a do-loop optimization -- an unattached slot */ s7_pointer y; new_cell(sc, y, T_SLOT); slot_set_symbol(y, variable); @@ -8247,11 +8244,13 @@ static s7_pointer g_simple_inlet(s7_scheme *sc, s7_pointer args) for (x = args; is_pair(x); x = cddr(x)) { s7_pointer symbol, slot; + symbol = car(x); if (is_keyword(symbol)) /* (inlet ':allow-other-keys 3) */ symbol = keyword_symbol(symbol); if (is_constant_symbol(sc, symbol)) /* (inlet 'pi 1) */ return(wrong_type_argument_with_type(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string)); + new_cell_no_check(sc, slot, T_SLOT); slot_set_symbol(slot, symbol); slot_set_value(slot, cadr(x)); @@ -8274,6 +8273,9 @@ static s7_pointer inlet_p_pp(s7_scheme *sc, s7_pointer symbol, s7_pointer value) symbol = keyword_symbol(symbol); if (is_constant_symbol(sc, symbol)) return(wrong_type_argument_with_type(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string)); + if ((is_global(symbol)) && + (is_syntax(slot_value(global_slot(symbol))))) + return(wrong_type_argument_with_type(sc, sc->inlet_symbol, 1, symbol, wrap_string(sc, "a non-syntactic name", 20))); new_cell(sc, x, T_LET | T_SAFE_PROCEDURE); sc->temp3 = x; @@ -9000,7 +9002,7 @@ static inline s7_pointer lookup(s7_scheme *sc, s7_pointer symbol) /* lookup_chec if (slot_symbol(y) == symbol) return(slot_value(y)); } - /* if (is_global(symbol)) fprintf(stderr, "%s in %s\n", DISPLAY(symbol), DISPLAY_80(sc->code)); */ + /* if (is_global(symbol)) fprintf(stderr, "%s in %s\n", display(symbol), display_80(sc->code)); */ x = global_slot(symbol); if (is_slot(x)) return(slot_value(x)); #if WITH_GCC @@ -9504,7 +9506,7 @@ static int tree_is_cyclic_or_has_pairs(s7_scheme *sc, s7_pointer tree) if (fast == slow) return(TREE_CYCLIC); } #if S7_DEBUGGING - if (!has_pairs) fprintf(stderr, "at end but no pairs: %s\n", DISPLAY(tree)); + if (!has_pairs) fprintf(stderr, "at end but no pairs: %s\n", display(tree)); #endif return(TREE_HAS_PAIRS); } @@ -10374,7 +10376,7 @@ static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c) dynamic_wind_state(x) = DWIND_FINISH; if (dynamic_wind_out(x) != sc->F) { - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); sc->args = sc->nil; sc->code = dynamic_wind_out(x); eval(sc, OP_APPLY); @@ -10419,7 +10421,7 @@ static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c) x = stack_code(continuation_stack(c), i); if (dynamic_wind_in(x) != sc->F) { - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); sc->args = sc->nil; sc->code = dynamic_wind_in(x); eval(sc, OP_APPLY); @@ -10591,7 +10593,7 @@ static void call_with_exit(s7_scheme *sc) dynamic_wind_state(lx) = DWIND_FINISH; if (dynamic_wind_out(lx) != sc->F) { - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); sc->args = sc->nil; sc->code = dynamic_wind_out(lx); eval(sc, OP_APPLY); @@ -12729,8 +12731,8 @@ static s7_pointer check_sharp_readers(s7_scheme *sc, const char *name) * The procedure can call read-char to read ahead in the current-input-port. * If it returns anything other than #f, that is the value of the sharp expression. * Since #f means "nothing found", it is tricky to handle #F: - * (cons #\F (lambda (str) (and (string=? str "F") (list 'not #t)))) - * This search happens after #|, #t, and #f (and #nD for multivectors?). #! has a fallback. + * (cons #\F (lambda (str) (and (string=? str "F") (list 'not #t)))) ; or ''#f used in lint.scm + * This search happens after #|, #t, and #f (and #nD for multivectors?). #! has a fallback. Added #_ later) */ need_loader_port = is_loader_port(sc->input_port); @@ -12812,6 +12814,23 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool with_error { /* name is the stuff after the '#', return sc->nil if not a recognized #... entity */ + if (name[0] == '_') + { + /* this needs to be unsettable via *#readers*: + * (set! *#readers* (list (cons #\_ (lambda (str) (string->symbol (substring str 1)))))) + * (let ((+ -)) (#_+ 1 2)): -1 + */ + s7_pointer sym; + sym = make_symbol(sc, (char *)(name + 1)); + if ((!is_gensym(sym)) && (is_slot(initial_slot(sym)))) + return(slot_value(initial_slot(sym))); + /* here we should not necessarily raise an error that *_... is undefined. reader-cond, for example, needs to + * read undefined #_ vals that it will eventually discard. + */ + return(make_unknown(sc, name)); /* (define x (with-input-from-string "(#_asdf 1 2)" read)) (type-of (car x)) -> undefined? */ + } + + /* stupid r7rs special cases */ if ((name[0] == 't') && ((name[1] == '\0') || (strings_are_equal(name, "true")))) return(sc->T); @@ -12852,19 +12871,6 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool with_error case 'b': /* #b (binary) */ return(make_atom(sc, (char *)(name + 1), (name[0] == 'o') ? 8 : ((name[0] == 'x') ? 16 : 2), NO_SYMBOLS, with_error)); - /* -------- #_... -------- */ - case '_': - { - s7_pointer sym; - sym = make_symbol(sc, (char *)(name + 1)); - if ((!is_gensym(sym)) && (is_slot(initial_slot(sym)))) - return(slot_value(initial_slot(sym))); - /* here we should not necessarily raise an error that *_... is undefined. reader-cond, for example, needs to - * read undefined #_ vals that it will eventually discard. - */ - return(make_unknown(sc, name)); /* (define x (with-input-from-string "(#_asdf 1 2)" read)) (type-of (car x)) -> undefined? */ - } - /* -------- #\... -------- */ case '\\': if (name[2] == 0) /* the most common case: #\a */ @@ -13478,13 +13484,17 @@ static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_sym break; case 'n': +#if (!DISABLE_DEPRECATED) if (local_strcmp(p, "an.0")) /* nan.0 */ return(real_NaN); +#endif return((want_symbol) ? make_symbol(sc, q) : sc->F); case 'i': +#if (!DISABLE_DEPRECATED) if (local_strcmp(p, "nf.0")) /* inf.0 */ return(real_infinity); +#endif return((want_symbol) ? make_symbol(sc, q) : sc->F); case '0': /* these two are always digits */ @@ -13912,7 +13922,7 @@ static bool is_rational_via_method(s7_scheme *sc, s7_pointer p) /* used in gmp a if (has_active_methods(sc, p)) { s7_pointer f; - f = find_method(sc, find_let(sc, p), sc->is_rational_symbol); + f = find_method_with_let(sc, p, sc->is_rational_symbol); if (f != sc->undefined) return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil)))); } @@ -13975,12 +13985,10 @@ static double my_hypot(double x, double y) return(sqrt(x * x + y * y)); } -static s7_pointer g_magnitude(s7_scheme *sc, s7_pointer args) +static s7_pointer magnitude_p_p(s7_scheme *sc, s7_pointer x) { - #define H_magnitude "(magnitude z) returns the magnitude of z" - #define Q_magnitude s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) - s7_pointer x; - x = car(args); + if (is_t_complex(x)) + return(make_real(sc, my_hypot(imag_part(x), real_part(x)))); switch (type(x)) { @@ -14006,14 +14014,18 @@ static s7_pointer g_magnitude(s7_scheme *sc, s7_pointer args) return(make_real(sc, -real(x))); return(x); - case T_COMPLEX: - return(make_real(sc, my_hypot(imag_part(x), real_part(x)))); - default: - return(method_or_bust_with_type_one_arg(sc, x, sc->magnitude_symbol, args, a_number_string)); + return(method_or_bust_with_type_one_arg(sc, x, sc->magnitude_symbol, list_1(sc, x), a_number_string)); } } +static s7_pointer g_magnitude(s7_scheme *sc, s7_pointer args) +{ + #define H_magnitude "(magnitude z) returns the magnitude of z" + #define Q_magnitude s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) + return(magnitude_p_p(sc, car(args))); +} + /* -------------------------------- rationalize -------------------------------- */ static s7_pointer g_rationalize(s7_scheme *sc, s7_pointer args) @@ -14506,11 +14518,9 @@ static s7_pointer g_sin(s7_scheme *sc, s7_pointer args) s7_pointer x; x = car(args); + if (is_t_real(x)) return(make_real(sc, sin(real(x)))); switch (type(x)) { - case T_REAL: - return(make_real(sc, sin(real(x)))); - case T_INTEGER: if (integer(x) == 0) return(small_int(0)); /* (sin 0) -> 0 */ return(make_real(sc, sin((s7_double)integer(x)))); @@ -14645,6 +14655,7 @@ static s7_pointer g_asin(s7_scheme *sc, s7_pointer args) s7_pointer n; n = car(args); + if (is_t_real(n)) return(c_asin(sc, real(n))); switch (type(n)) { case T_INTEGER: @@ -14655,9 +14666,6 @@ static s7_pointer g_asin(s7_scheme *sc, s7_pointer args) case T_RATIO: return(c_asin(sc, (s7_double)numerator(n) / (s7_double)denominator(n))); - case T_REAL: - return(c_asin(sc, real(n))); - case T_COMPLEX: #if HAVE_COMPLEX_NUMBERS /* if either real or imag part is very large, use explicit formula, not casin */ @@ -15512,16 +15520,9 @@ static s7_int c_quo_dbl(s7_scheme *sc, s7_double x, s7_double y) static s7_int quotient_i_7ii(s7_scheme *sc, s7_int i1, s7_int i2) {return(c_quo_int(sc, i1, i2));} static s7_int quotient_i_ii_direct(s7_int i1, s7_int i2) {return(i1 / i2);} /* i2 > 0 */ -static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args) +static s7_pointer quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { - #define H_quotient "(quotient x1 x2) returns the integer quotient of x1 and x2; (quotient 4 3) = 1" - #define Q_quotient s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_real_symbol, sc->is_real_symbol) - /* (define (quo x1 x2) (truncate (/ x1 x2))) ; slib */ - s7_pointer x, y; s7_int d1, d2, n1, n2; - - x = car(args); - y = cadr(args); if ((is_t_integer(x)) && (is_t_integer(y))) return(make_integer(sc, c_quo_int(sc, integer(x), integer(y)))); @@ -15543,13 +15544,13 @@ static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args) case T_REAL: if (real(y) == 0.0) - return(division_by_zero_error(sc, sc->quotient_symbol, args)); + return(division_by_zero_error(sc, sc->quotient_symbol, set_elist_2(sc, x, y))); if ((is_inf(real(y))) || (is_NaN(real(y)))) return(wrong_type_argument_with_type(sc, sc->quotient_symbol, 2, y, a_normal_real_string)); return(s7_truncate(sc, sc->quotient_symbol, (s7_double)integer(x) / real(y))); /* s7_truncate returns an integer */ default: - return(method_or_bust(sc, y, sc->quotient_symbol, args, T_REAL, 2)); + return(method_or_bust(sc, y, sc->quotient_symbol, list_2(sc, x, y), T_REAL, 2)); } case T_RATIO: @@ -15557,7 +15558,7 @@ static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args) { case T_INTEGER: if (integer(y) == 0) - return(division_by_zero_error(sc, sc->quotient_symbol, args)); + return(division_by_zero_error(sc, sc->quotient_symbol, set_elist_2(sc, x, y))); n1 = numerator(x); d1 = denominator(x); n2 = integer(y); @@ -15592,13 +15593,13 @@ static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args) case T_REAL: if (real(y) == 0.0) - return(division_by_zero_error(sc, sc->quotient_symbol, args)); + return(division_by_zero_error(sc, sc->quotient_symbol, set_elist_2(sc, x, y))); if ((is_inf(real(y))) || (is_NaN(real(y)))) return(wrong_type_argument_with_type(sc, sc->quotient_symbol, 2, y, a_normal_real_string)); return(s7_truncate(sc, sc->quotient_symbol, (s7_double)fraction(x) / real(y))); default: - return(method_or_bust(sc, y, sc->quotient_symbol, args, T_REAL, 2)); + return(method_or_bust(sc, y, sc->quotient_symbol, list_2(sc, x, y), T_REAL, 2)); } case T_REAL: @@ -15614,7 +15615,7 @@ static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args) { case T_INTEGER: if (integer(y) == 0) - return(division_by_zero_error(sc, sc->quotient_symbol, args)); + return(division_by_zero_error(sc, sc->quotient_symbol, set_elist_2(sc, x, y))); return(s7_truncate(sc, sc->quotient_symbol, real(x) / (s7_double)integer(y))); case T_RATIO: @@ -15624,14 +15625,22 @@ static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args) return(make_integer(sc, c_quo_dbl(sc, real(x), real(y)))); /* c_quo_dbl returns an integer */ default: - return(method_or_bust(sc, y, sc->quotient_symbol, args, T_REAL, 2)); + return(method_or_bust(sc, y, sc->quotient_symbol, list_2(sc, x, y), T_REAL, 2)); } default: - return(method_or_bust(sc, x, sc->quotient_symbol, args, T_REAL, 2)); + return(method_or_bust(sc, x, sc->quotient_symbol, list_2(sc, x, y), T_REAL, 2)); } } +static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args) +{ + #define H_quotient "(quotient x1 x2) returns the integer quotient of x1 and x2; (quotient 4 3) = 1" + #define Q_quotient s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_real_symbol, sc->is_real_symbol) + /* (define (quo x1 x2) (truncate (/ x1 x2))) ; slib */ + return(quotient_p_pp(sc, car(args), cadr(args))); +} + /* -------------------------------- remainder -------------------------------- */ static inline s7_int c_rem_int(s7_scheme *sc, s7_int x, s7_int y) @@ -16831,7 +16840,29 @@ static inline s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) } static s7_pointer g_add_2(s7_scheme *sc, s7_pointer args) {return(add_p_pp(sc, car(args), cadr(args)));} -static s7_pointer g_add_3(s7_scheme *sc, s7_pointer args) {return(add_p_pp(sc, add_p_pp(sc, car(args), cadr(args)), caddr(args)));} + +static s7_pointer g_add_3(s7_scheme *sc, s7_pointer args) +{ + s7_pointer p0, p1, p2; + p0 = car(args); + p1 = cadr(args); + p2 = caddr(args); + if ((is_t_integer(p0)) && (is_t_integer(p1)) && (is_t_integer(p2))) + { +#if HAVE_OVERFLOW_CHECKS + s7_int val; + if ((!add_overflow(integer(p0), integer(p1), &val)) && + (!add_overflow(val, integer(p2), &val))) + return(make_integer(sc, val)); + return(make_real(sc, (double)integer(p0) + (double)integer(p1) + (double)integer(p2))); +#else + return(make_integer(sc, integer(p0) + integer(p1) + integer(p2))); +#endif + } + if ((is_t_real(p0)) && (is_t_real(p1)) && (is_t_real(p2))) + return(make_real(sc, real(p0) + real(p1) + real(p2))); + return(add_p_pp(sc, add_p_pp(sc, p0, p1), p2)); +} /* trade-off in add_3: time saved by using add_p_pp, but it conses up a new number cell, so subsequent gc can overwhelm the gains, and add add_p_pp overhead */ static s7_pointer g_add_x1_1(s7_scheme *sc, s7_pointer x, s7_pointer args) @@ -17396,7 +17427,10 @@ static s7_pointer minus_c1(s7_scheme *sc, s7_pointer x) static s7_pointer g_subtract_s1(s7_scheme *sc, s7_pointer args) { - return(minus_c1(sc, car(args))); + s7_pointer p; + p = car(args); + if (is_t_integer(p)) return(make_integer(sc, integer(p) - 1)); + return(minus_c1(sc, p)); } static s7_pointer g_subtract_2f(s7_scheme *sc, s7_pointer args) /* (- x f) */ @@ -17452,6 +17486,30 @@ static s7_double subtract_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_do #if (!WITH_GMP) static s7_pointer sub_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 - x2));} + +static s7_pointer g_sub_xi(s7_scheme *sc, s7_pointer x, s7_int y) +{ + if (is_t_integer(x)) + { +#if HAVE_OVERFLOW_CHECKS + s7_int val; + if (subtract_overflow(integer(x), y, &val)) + return(make_real(sc, (double)integer(x) - (double)y)); + return(make_integer(sc, val)); +#else + return(make_integer(sc, integer(x) - y)); +#endif + } + switch (type(x)) + { + case T_RATIO: return(s7_make_ratio(sc, numerator(x) - (y * denominator(x)), denominator(x))); + case T_REAL: return(make_real(sc, real(x) - y)); + case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - y, imag_part(x))); + default: + return(method_or_bust_with_type(sc, x, sc->subtract_symbol, list_2(sc, x, make_integer(sc, y)), a_number_string, 1)); + } + return(x); +} #endif @@ -17993,14 +18051,14 @@ static bool is_number_via_method(s7_scheme *sc, s7_pointer p) if (has_active_methods(sc, p)) { s7_pointer f; - f = find_method(sc, find_let(sc, p), sc->is_number_symbol); + f = find_method_with_let(sc, p, sc->is_number_symbol); if (f != sc->undefined) return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil)))); } return(false); } -static s7_pointer g_divide_xy(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer args) +static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { /* splitting out real/real here saves very little */ switch (type(x)) @@ -18030,7 +18088,7 @@ static s7_pointer g_divide_xy(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_poin if (is_NaN(real(y))) return(real_NaN); if (is_inf(real(y))) return(real_zero); if (real(y) == 0.0) - return(division_by_zero_error(sc, sc->divide_symbol, args)); + return(division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, x, y))); return(make_real(sc, (s7_double)(integer(x)) / real(y))); case T_COMPLEX: @@ -18097,7 +18155,7 @@ static s7_pointer g_divide_xy(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_poin case T_REAL: if (real(y) == 0.0) - return(division_by_zero_error(sc, sc->divide_symbol, args)); + return(division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, x, y))); return(make_real(sc, fraction(x) / real(y))); case T_COMPLEX: @@ -18120,7 +18178,7 @@ static s7_pointer g_divide_xy(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_poin { case T_INTEGER: if (integer(y) == 0) - return(division_by_zero_error(sc, sc->divide_symbol, args)); + return(division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, x, y))); if (is_NaN(real(x))) return(real_NaN); /* what is (/ +nan.0 0)? */ if (is_inf(real(x))) return((real(x) > 0.0) ? ((integer(y) > 0) ? real_infinity : real_minus_infinity) : ((integer(y) > 0) ? real_minus_infinity : real_infinity)); return(make_real(sc, real(x) / (s7_double)integer(y))); @@ -18133,7 +18191,7 @@ static s7_pointer g_divide_xy(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_poin case T_REAL: if (is_NaN(real(y))) return(real_NaN); if (real(y) == 0.0) - return(division_by_zero_error(sc, sc->divide_symbol, args)); + return(division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, x, y))); if (is_NaN(real(x))) return(real_NaN); if (is_inf(real(y))) { @@ -18167,7 +18225,7 @@ static s7_pointer g_divide_xy(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_poin { s7_double r1; if (integer(y) == 0) - return(division_by_zero_error(sc, sc->divide_symbol, args)); + return(division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, x, y))); r1 = 1.0 / (s7_double)integer(y); return(s7_make_complex(sc, real_part(x) * r1, imag_part(x) * r1)); } @@ -18183,7 +18241,7 @@ static s7_pointer g_divide_xy(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_poin { s7_double r1; if (real(y) == 0.0) - return(division_by_zero_error(sc, sc->divide_symbol, args)); + return(division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, x, y))); r1 = 1.0 / real(y); return(s7_make_complex(sc, real_part(x) * r1, imag_part(x) * r1)); } @@ -18235,14 +18293,14 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args) return(s7_invert(sc, x)); } if (is_null(cdr(p))) - return(g_divide_xy(sc, x, cadr(args), args)); + return(divide_p_pp(sc, x, cadr(args))); y = g_multiply_1(sc, p, sc->divide_symbol); /* in some schemes (/ 1 0 +nan.0) is not equal to (/ 1 (* 0 +nan.0)), in s7 they're both +nan.0 */ #if WITH_GMP if (s7_is_bignum(y)) return(big_divide(sc, set_plist_2(sc, x, y))); #endif - return(g_divide_xy(sc, x, y, args)); + return(divide_p_pp(sc, x, y)); } #if (!WITH_GMP) @@ -18275,7 +18333,7 @@ static s7_pointer g_invert_1(s7_scheme *sc, s7_pointer args) static s7_pointer g_divide_2(s7_scheme *sc, s7_pointer args) { - return(g_divide_xy(sc, car(args), cadr(args), args)); + return(divide_p_pp(sc, car(args), cadr(args))); } static s7_pointer g_divide_by_2(s7_scheme *sc, s7_pointer args) @@ -18340,7 +18398,7 @@ static s7_pointer divide_p_i(s7_scheme *sc, s7_int x) {return(s7_make_ratio(sc, static bool is_real_via_method_1(s7_scheme *sc, s7_pointer p) { s7_pointer f; - f = find_method(sc, find_let(sc, p), sc->is_real_symbol); + f = find_method_with_let(sc, p, sc->is_real_symbol); if (f != sc->undefined) return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil)))); return(false); @@ -18867,16 +18925,10 @@ static bool num_eq_b_pi(s7_scheme *sc, s7_pointer x, s7_int y) { if (is_t_integer(x)) return(integer(x) == y); - - switch (type(x)) - { - case T_INTEGER: return(integer(x) == y); - case T_RATIO: return(false); - case T_REAL: return(real(x) == y); - case T_COMPLEX: return(false); - default: - simple_wrong_type_argument_with_type(sc, sc->num_eq_symbol, x, a_number_string); - } + if (is_t_real(x)) + return(real(x) == y); + if (!is_number(x)) + simple_wrong_type_argument_with_type(sc, sc->num_eq_symbol, x, a_number_string); return(false); } @@ -20337,13 +20389,8 @@ s7_double s7_imag_part(s7_pointer x) return(0.0); } -static s7_pointer g_real_part(s7_scheme *sc, s7_pointer args) +static s7_pointer real_part_p_p(s7_scheme *sc, s7_pointer p) { - #define H_real_part "(real-part num) returns the real part of num" - #define Q_real_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) - - s7_pointer p; - p = car(args); switch (type(p)) { case T_INTEGER: @@ -20374,19 +20421,21 @@ static s7_pointer g_real_part(s7_scheme *sc, s7_pointer args) #endif default: - return(method_or_bust_with_type_one_arg(sc, p, sc->real_part_symbol, args, a_number_string)); + return(method_or_bust_with_type_one_arg(sc, p, sc->real_part_symbol, list_1(sc, p), a_number_string)); } } -static s7_pointer g_imag_part(s7_scheme *sc, s7_pointer args) +static s7_pointer g_real_part(s7_scheme *sc, s7_pointer args) { - #define H_imag_part "(imag-part num) returns the imaginary part of num" - #define Q_imag_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) - s7_pointer p; - /* currently (imag-part +nan.0) -> 0.0 ? it's true but maybe confusing */ + #define H_real_part "(real-part num) returns the real part of num" + #define Q_real_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) + return(real_part_p_p(sc, car(args))); +} - p = car(args); - switch (type(p)) + +static s7_pointer imag_part_p_p(s7_scheme *sc, s7_pointer p) +{ + switch (type(p)) { case T_INTEGER: case T_RATIO: @@ -20419,10 +20468,18 @@ static s7_pointer g_imag_part(s7_scheme *sc, s7_pointer args) #endif default: - return(method_or_bust_with_type_one_arg(sc, p, sc->imag_part_symbol, args, a_number_string)); + return(method_or_bust_with_type_one_arg(sc, p, sc->imag_part_symbol, list_1(sc, p), a_number_string)); } } +static s7_pointer g_imag_part(s7_scheme *sc, s7_pointer args) +{ + #define H_imag_part "(imag-part num) returns the imaginary part of num" + #define Q_imag_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) + /* currently (imag-part +nan.0) -> 0.0 ? it's true but maybe confusing */ + return(imag_part_p_p(sc, car(args))); +} + /* ---------------------------------------- numerator denominator ---------------------------------------- */ @@ -21609,7 +21666,7 @@ static void init_chars(void) set_type(eof_object, T_EOF_OBJECT | T_IMMUTABLE | T_UNHEAP); unique_name_length(eof_object) = 6; unique_name(eof_object) = "#<eof>"; - chars++; /* now chars[EOF] == chars[-1] == eof_object */ + chars++; /* now chars[EOF] == chars[-1] == #<eof> */ cells++; for (i = 0; i < NUM_CHARS; i++) @@ -21740,7 +21797,7 @@ static bool is_char_whitespace_b_7p(s7_scheme *sc, s7_pointer c) if (has_active_methods(sc, c)) { s7_pointer f; - f = find_method(sc, find_let(sc, c), sc->is_char_whitespace_symbol); + f = find_method_with_let(sc, c, sc->is_char_whitespace_symbol); if (f != sc->undefined) return(is_true(sc, s7_apply_function(sc, f, cons(sc, c, sc->nil)))); } @@ -21842,7 +21899,7 @@ static bool is_character_via_method(s7_scheme *sc, s7_pointer p) if (has_active_methods(sc, p)) { s7_pointer f; - f = find_method(sc, find_let(sc, p), sc->is_char_symbol); + f = find_method_with_let(sc, p, sc->is_char_symbol); if (f != sc->undefined) return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil)))); } @@ -22793,7 +22850,7 @@ static void unstack_1(s7_scheme *sc, const char *func, int line) if (((opcode_t)sc->stack_end[3]) != OP_GC_PROTECT) { fprintf(stderr, "%s%s[%d]: popped %s?%s\n", BOLD_TEXT, func, line, op_names[(opcode_t)sc->stack_end[3]], UNBOLD_TEXT); - fprintf(stderr, " code: %s, args: %s\n", DISPLAY(sc->code), DISPLAY(sc->args)); + fprintf(stderr, " code: %s, args: %s\n", display(sc->code), display(sc->args)); } } #else @@ -22824,7 +22881,7 @@ static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer c if (has_active_methods(sc, p)) { s7_pointer func; - func = find_method(sc, find_let(sc, p), caller); + func = find_method_with_let(sc, p, caller); if (func != sc->undefined) { s7_pointer y; @@ -23031,7 +23088,7 @@ static bool is_string_via_method(s7_scheme *sc, s7_pointer p) if (has_active_methods(sc, p)) { s7_pointer f; - f = find_method(sc, find_let(sc, p), sc->is_string_symbol); + f = find_method_with_let(sc, p, sc->is_string_symbol); if (f != sc->undefined) return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil)))); } @@ -23465,7 +23522,7 @@ static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym) if (has_active_methods(sc, p)) { s7_pointer func; - func = find_method(sc, find_let(sc, p), sym); + func = find_method_with_let(sc, p, sym); if (func != sc->undefined) { s7_pointer y; @@ -25493,7 +25550,7 @@ s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc static inline void push_input_port(s7_scheme *sc, s7_pointer new_port) { #if S7_DEBUGGING - if (!is_input_port(new_port)) fprintf(stderr, "push %s\n", DISPLAY(new_port)); + if (!is_input_port(new_port)) fprintf(stderr, "push %s\n", display(new_port)); #endif if (sc->input_port_stack_loc >= sc->input_port_stack_size) { @@ -25589,6 +25646,13 @@ static s7_pointer g_read_char(s7_scheme *sc, s7_pointer args) return(chars[port_read_character(port)(sc, port)]); } +static s7_pointer read_char_p_p(s7_scheme *sc, s7_pointer port) +{ + if (!is_input_port(port)) + return(method_or_bust_with_type_one_arg(sc, port, sc->read_char_symbol, list_1(sc, port), an_input_port_string)); + return(chars[port_read_character(port)(sc, port)]); +} + static s7_pointer g_read_char_1(s7_scheme *sc, s7_pointer args) { s7_pointer port; @@ -25915,7 +25979,7 @@ s7_pointer s7_read(s7_scheme *sc, s7_pointer port) else { push_stack_no_let_no_code(sc, OP_BARRIER, port); - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); eval(sc, OP_READ_INTERNAL); @@ -26757,7 +26821,7 @@ s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_ { s7_pointer code, port, result; TRACK(sc); - push_stack(sc, OP_GC_PROTECT, sc->args, sc->code); + push_stack_direct(sc, OP_GC_PROTECT, sc->args, sc->code); /* maybe this should just use locals? (GC protection is not the issue here), * but this is way down in the noise -- read/eval below are 99% of the computing */ @@ -26921,7 +26985,7 @@ static s7_pointer g_with_input_from_string(s7_scheme *sc, s7_pointer args) if (!is_string(str)) return(method_or_bust(sc, str, sc->with_input_from_string_symbol, args, T_STRING, 1)); - if (cadr(args) == slot_value(global_slot(sc->read_symbol))) + if (cadr(args) == slot_value(global_slot(sc->read_symbol))) /* if chooser for this, make_function_with_class needs to handle unsafe functions */ { s7_pointer old_input_port; if (string_length(str) == 0) @@ -27206,7 +27270,7 @@ static s7_pointer c_object_iterate(s7_scheme *sc, s7_pointer obj) p = iterator_sequence(obj); cur = iterator_current(obj); set_car(sc->z2_1, sc->x); - set_car(sc->z2_2, sc->z); /* is this necessary? */ + set_car(sc->z2_2, sc->z); /* is this necessary? (save/restore sc->x/y across c_object iteration) */ set_car(cur, p); set_car(cdr(cur), make_integer(sc, iterator_position(obj))); result = (*(c_object_ref(sc, p)))(sc, cur); @@ -27259,7 +27323,7 @@ static s7_pointer iterator_method(s7_scheme *sc, s7_pointer e) { s7_pointer func; if ((has_active_methods(sc, e)) && - ((func = find_method(sc, find_let(sc, e), sc->make_iterator_symbol)) != sc->undefined)) + ((func = find_method_with_let(sc, e, sc->make_iterator_symbol)) != sc->undefined)) { s7_pointer it; it = s7_apply_function(sc, func, list_1(sc, e)); @@ -27452,7 +27516,7 @@ in the sequence each time it is called. When it reaches the end, it returns " I else /* (let-temporarily (((*s7* 'safety) 1)) (make-iterator "asdf" (cons 1 2))) */ { if (sc->safety > MORE_SAFETY_WARNINGS) - s7_warn(sc, 256, "(make-iterator %s %s) does not need the second argument\n", DISPLAY_80(seq), DISPLAY_80(carrier)); + s7_warn(sc, 256, "(make-iterator %s %s) does not need the second argument\n", display_80(seq), display_80(carrier)); } } } @@ -30454,14 +30518,14 @@ void s7_show_let(s7_scheme *sc) /* debugging convenience */ else { if (is_funclet(olet)) - fprintf(stderr, "(%s funclet): ", DISPLAY(funclet_function(olet))); + fprintf(stderr, "(%s funclet): ", display(funclet_function(olet))); else { if (olet == sc->shadow_rootlet) fprintf(stderr, "(shadow rootlet): "); } } - fprintf(stderr, "%s\n", DISPLAY(olet)); + fprintf(stderr, "%s\n", display(olet)); } } @@ -30484,9 +30548,9 @@ void s7_show_history(s7_scheme *sc) int32_t i, size; size = sc->history_size; for (i = 0, p = cdr(sc->cur_code); i < size; i++, p = cdr(p)) /* stepper "i" is not redundant */ - safe_print(fprintf(stderr, "%s\n", DISPLAY(car(p)))); + safe_print(fprintf(stderr, "%s\n", display(car(p)))); #else - fprintf(stderr, "%s\n", DISPLAY(sc->cur_code)); + fprintf(stderr, "%s\n", display(sc->cur_code)); #endif } @@ -31191,7 +31255,7 @@ static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, in fprintf(stderr, " symbol_id: %" print_s7_int ", let_id: %" print_s7_int ", bits: %s", symbol_id(sym), let_id(sc->envir), s = describe_type_bits(sc, sym)); free(s); slot = symbol_to_local_slot(sc, sym, sc->envir); - if (is_slot(slot)) fprintf(stderr, ", slot: %s", DISPLAY(slot)); + if (is_slot(slot)) fprintf(stderr, ", slot: %s", display(slot)); fprintf(stderr, "\n"); if (sc->stop_at_error) abort(); } @@ -31488,7 +31552,7 @@ static void counter_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_ #if S7_DEBUGGING char data[256]; size_t len; - len = snprintf(data, 256, "#<counter: %s %s %s>", DISPLAY_80(counter_list(obj)), DISPLAY_80(counter_result(obj)), DISPLAY_80(counter_let(obj))); + len = snprintf(data, 256, "#<counter: %s %s %s>", display_80(counter_list(obj)), display_80(counter_result(obj)), display_80(counter_let(obj))); port_write_string(port)(sc, data, len, port); #else port_write_string(port)(sc, "#<counter>", 10, port); @@ -31599,16 +31663,15 @@ static void macro_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_wr static void c_function_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info *ci) { - if (use_write == P_READABLE) + s7_pointer sym; + sym = make_symbol(sc, c_function_name(obj)); + if ((!is_global(sym)) && + (is_slot(initial_slot(sym))) && + ((use_write == P_READABLE) || (lookup(sc, sym) != slot_value(initial_slot(sym))))) { - s7_pointer sym; - sym = make_symbol(sc, c_function_name(obj)); - if ((is_slot(initial_slot(sym))) && (!is_global(sym))) - { - port_write_string(port)(sc, "#_", 2, port); - port_write_string(port)(sc, c_function_name(obj), c_function_name_length(obj), port); - return; - } + port_write_string(port)(sc, "#_", 2, port); + port_write_string(port)(sc, c_function_name(obj), c_function_name_length(obj), port); + return; } if (c_function_name_length(obj) > 0) port_write_string(port)(sc, c_function_name(obj), c_function_name_length(obj), port); @@ -32637,7 +32700,7 @@ static bool format_method(s7_scheme *sc, const char *str, format_data *fdat, s7_ obj = car(fdat->args); if ((!has_active_methods(sc, obj)) || - ((func = find_method(sc, find_let(sc, obj), sc->format_symbol)) == sc->undefined)) + ((func = find_method_with_let(sc, obj, sc->format_symbol)) == sc->undefined)) return(false); ctrl_str[0] = '~'; @@ -34834,6 +34897,33 @@ static s7_pointer list_set_p_pip_direct(s7_scheme *sc, s7_pointer p1, s7_int i1, return(p2); } +static s7_pointer list_increment_p_pip_direct(opt_info *o) +{ + s7_scheme *sc; + s7_pointer p, p1, p2; + s7_int i, index; + sc = o->sc; + p = slot_value(o->v[2].p); + index = integer(p); + if ((index < 0) || (index > sc->max_list_length)) + out_of_range(sc, sc->list_set_symbol, small_int(2), p, (index < 0) ? its_negative_string : its_too_large_string); + p1 = slot_value(o->v[1].p); + for (i = 0, p = p1; ((is_pair(p)) && (i < index)); i++, p = cdr(p)); + if (!is_pair(p)) + { + if (type(p) == T_NIL) + out_of_range(sc, sc->list_set_symbol, small_int(2), wrap_integer1(sc, index), its_too_large_string); + else simple_wrong_type_argument_with_type(sc, sc->list_set_symbol, p1, a_proper_list_string); + } +#if (!WITH_GMP) + p2 = g_add_xi(sc, car(p), integer(o->v[3].p)); +#else + p2 = g_add(sc, list_2(sc, car(p), make_integer(sc, integer(o->v[3].p)))); +#endif + set_car(p, p2); + return(p2); +} + static s7_pointer list_set_p_pip(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2) { if (!is_pair(p1)) @@ -34869,17 +34959,11 @@ static s7_pointer g_list_set_i(s7_scheme *sc, s7_pointer args) /* -------------------------------- list-tail -------------------------------- */ -static s7_pointer g_list_tail(s7_scheme *sc, s7_pointer args) +static s7_pointer list_tail_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer p) { - #define H_list_tail "(list-tail lst i) returns the list from the i-th element on" - #define Q_list_tail s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol) /* #t: (list-tail '(1 . 2) 1) -> 2 */ - s7_pointer lst, p; s7_int i, index; - - lst = car(args); - p = cadr(args); if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->list_tail_symbol, args, T_INTEGER, 2)); + return(method_or_bust(sc, p, sc->list_tail_symbol, list_2(sc, lst, p), T_INTEGER, 2)); index = s7_integer(p); if (!is_list(lst)) @@ -34894,6 +34978,13 @@ static s7_pointer g_list_tail(s7_scheme *sc, s7_pointer args) return(p); } +static s7_pointer g_list_tail(s7_scheme *sc, s7_pointer args) +{ + #define H_list_tail "(list-tail lst i) returns the list from the i-th element on" + #define Q_list_tail s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol) /* #t: (list-tail '(1 . 2) 1) -> 2 */ + return(list_tail_p_pp(sc, car(args), cadr(args))); +} + /* -------------------------------- cons -------------------------------- */ static s7_pointer g_cons(s7_scheme *sc, s7_pointer args) @@ -35680,7 +35771,6 @@ If 'func' is a function of 2 arguments, it is used for the comparison instead of for (; is_pair(x); x = cdr(x)) { slot_set_value(b, caar(x)); - sc->pc = 0; if (o->v[0].fb(o)) return(car(x)); } @@ -35794,9 +35884,9 @@ static bool assoc_if(s7_scheme *sc) return(true); } set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list */ - push_stack(sc, OP_ASSOC_IF, sc->args, sc->code); + push_stack_direct(sc, OP_ASSOC_IF, sc->args, sc->code); } - else push_stack(sc, OP_ASSOC_IF1, sc->args, sc->code); + else push_stack_direct(sc, OP_ASSOC_IF1, sc->args, sc->code); if (!is_pair(car(opt1_fast(orig_args)))) /* (assoc 1 '((2 . 2) 3) =) -- we access caaadr below */ eval_type_error(sc, "assoc: second arg is not an alist: ~S", 37, orig_args); @@ -35915,10 +36005,10 @@ static s7_pointer g_memq_any(s7_scheme *sc, s7_pointer args) static s7_pointer memq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) { if ((is_proper_quote(sc, caddr(expr))) && - (is_pair(cadr(caddr(expr))))) + (is_pair(cadaddr(expr)))) { s7_int len; - len = s7_list_length(sc, cadr(caddr(expr))); + len = s7_list_length(sc, cadaddr(expr)); if (len > 0) { if (len == 2) @@ -36152,13 +36242,11 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c for (slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) { slot_set_value(b, car(x)); - sc->pc = 0; if (fp(o) != sc->F) return(x); if (!is_pair(cdr(x))) return(sc->F); x = cdr(x); if (x == slow) return(sc->F); slot_set_value(b, car(x)); - sc->pc = 0; if (fp(o) != sc->F) return(x); } } @@ -36167,13 +36255,11 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c for (slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) { slot_set_value(b, car(x)); - sc->pc = 0; if (o->v[0].fb(o)) return(x); if (!is_pair(cdr(x))) return(sc->F); x = cdr(x); if (x == slow) return(sc->F); slot_set_value(b, car(x)); - sc->pc = 0; if (o->v[0].fb(o)) return(x); } } @@ -36252,9 +36338,9 @@ static bool member_if(s7_scheme *sc) return(true); } set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list (check for circular list) */ - push_stack(sc, OP_MEMBER_IF, sc->args, sc->code); + push_stack_direct(sc, OP_MEMBER_IF, sc->args, sc->code); } - else push_stack(sc, OP_MEMBER_IF1, sc->args, sc->code); + else push_stack_direct(sc, OP_MEMBER_IF1, sc->args, sc->code); if (needs_copied_args(sc->code)) sc->args = list_2(sc, caar(orig_args), car(opt1_fast(orig_args))); @@ -37218,7 +37304,7 @@ static s7_pointer g_vector_append(s7_scheme *sc, s7_pointer args) if (has_active_methods(sc, x)) { s7_pointer func; - func = find_method(sc, find_let(sc, x), sc->vector_append_symbol); + func = find_method_with_let(sc, x, sc->vector_append_symbol); if (func != sc->undefined) { int32_t k; @@ -38730,9 +38816,9 @@ static s7_pointer g_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) */ if (dims <= 0) /* #0d(...) #2147483649D() [if dims is int32_t this is negative] */ - return(s7_out_of_range_error(sc, "#nD(...) dimensions", 1, wrap_integer1(sc, dims), "must be 1 or more")); + return(s7_out_of_range_error(sc, "#nD(...) dimensions", 1, wrap_integer2(sc, dims), "must be 1 or more")); /* out_of_range uses integer1 */ if (dims > sc->max_vector_dimensions) - return(s7_out_of_range_error(sc, "#nD(...) dimensions", 1, wrap_integer1(sc, dims), "must be < 512")); /* sc->max_vector_dimensions=512 currently */ + return(s7_out_of_range_error(sc, "#nD(...) dimensions", 1, wrap_integer2(sc, dims), "must be < (*s7* 'max-vector-dimensions)")); sc->w = sc->nil; if (is_null(data)) /* dims are already 0 (calloc above) */ @@ -39566,7 +39652,6 @@ static bool c_function_is_ok(s7_scheme *sc, s7_pointer x) /* this is nearly always global and p == opt1_cfunc(x) * p can be null if we evaluate some code, optimizing it, then eval it again in a context * where the incoming p was undefined(!) -- explicit use of eval and so on. - * I guess ideally eval would ignore optimization info -- copy :readable or something. */ return((p == opt1_any(x)) || ((is_any_c_function(p)) && @@ -39790,7 +39875,6 @@ static int32_t opt_bool_sort(const void *v1, const void *v2, void *arg) s7_scheme *sc = (s7_scheme *)arg; slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); /* first slot in curlet */ slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); /* second slot in curlet */ - sc->pc = 0; /* always opt_bool_call here, so insert it */ return((sc->sort_fb(sc->sort_o)) ? -1 : 1); } @@ -39807,37 +39891,37 @@ static int32_t opt_bool_sort_p(const void *v1, const void *v2, void *arg) s7_scheme *sc = (s7_scheme *)arg; slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); - sc->pc = 0; return((sc->opts[0]->v[O_WRAP].fp(sc->opts[0]) == sc->F) ? 1 : -1); } +#define SORT_O1 1 static int32_t opt_begin_bool_sort_b(const void *v1, const void *v2, void *arg) { s7_scheme *sc = (s7_scheme *)arg; s7_int i; - opt_info *o; + opt_info *top, *o; slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); - sc->pc = -1; + top = sc->opts[0]; for (i = 0; i < sc->sort_body_len - 1; i++) { - o = sc->opts[++sc->pc]; /* 1..15? */ + o = top->v[SORT_O1 + i].o1; o->v[0].fp(o); } - o = sc->opts[++sc->pc]; + o = top->v[SORT_O1 + i].o1; return((o->v[0].fb(o)) ? -1 : 1); } static int32_t opt_begin_bool_sort_b2(const void *v1, const void *v2, void *arg) { s7_scheme *sc = (s7_scheme *)arg; - opt_info *o; + opt_info *top, *o; slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); - sc->pc = 0; - o = sc->opts[0]; + top = sc->opts[0]; + o = top->v[SORT_O1].o1; o->v[0].fp(o); - o = sc->opts[++sc->pc]; + o = top->v[SORT_O1 + 1].o1; return((o->v[0].fb(o)) ? -1 : 1); } @@ -39845,16 +39929,16 @@ static int32_t opt_begin_bool_sort_p(const void *v1, const void *v2, void *arg) { s7_scheme *sc = (s7_scheme *)arg; s7_int i; - opt_info *o; + opt_info *top, *o; slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); - sc->pc = -1; + top = sc->opts[0]; for (i = 0; i < sc->sort_body_len - 1; i++) { - o = sc->opts[++sc->pc]; /* 1..15? */ + o = top->v[SORT_O1 + i].o1; o->v[0].fp(o); } - o = sc->opts[++sc->pc]; + o = top->v[SORT_O1 + i].o1; return((o->v[0].fp(o) != sc->F) ? -1 : 1); } @@ -39882,6 +39966,13 @@ static int32_t closure_sort_begin(const void *v1, const void *v2, void *arg) } static s7_b_7pp_t s7_b_7pp_function(s7_pointer f); +#if S7_DEBUGGING +#define alloc_opo(Sc, Expr) alloc_opo_2(Sc, Expr, __func__, __LINE__) +static opt_info *alloc_opo_2(s7_scheme *sc, s7_pointer expr, const char *func, int line); +#else +#define alloc_opo(Sc, Expr) alloc_opo_1(Sc) +static opt_info *alloc_opo_1(s7_scheme *sc); +#endif static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) { @@ -39982,7 +40073,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) ((caadr(expr) == sc->car_symbol) || (caadr(expr) == sc->cdr_symbol)) && (caadr(expr) == caaddr(expr)) && (car(largs) == cadadr(expr)) && - (cadr(largs) == cadr(caddr(expr)))) + (cadr(largs) == cadaddr(expr))) { lp = lookup(sc, car(expr)); sc->sort_f = s7_b_7pp_function(lp); @@ -40015,42 +40106,55 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) sc->sort_v2 = next_slot(let_slots(sc->envir)); if (is_null(cdr(closure_body(lessp)))) { - s7_function sf1; - sf1 = s7_bool_optimize(sc, closure_body(lessp)); - if (sf1 == opt_bool_any) + if (!no_bool_opt(closure_body(lessp))) { - if (sc->opts[0]->v[0].fb == p_to_b) - sort_func = opt_bool_sort_p; - else + s7_function sf1; + sf1 = s7_bool_optimize(sc, closure_body(lessp)); + if (sf1 == opt_bool_any) { - sc->sort_o = sc->opts[0]; - sc->sort_fb = sc->sort_o->v[0].fb; - sort_func = (sc->pc == 1) ? opt_bool_sort_0 : opt_bool_sort; + if (sc->opts[0]->v[0].fb == p_to_b) + sort_func = opt_bool_sort_p; + else + { + sc->sort_o = sc->opts[0]; + sc->sort_fb = sc->sort_o->v[0].fb; + sort_func = (sc->pc == 1) ? opt_bool_sort_0 : opt_bool_sort; + } } + else set_no_bool_opt(closure_body(lessp)); } } else { if (setjmp(sc->opt_exit) == 0) { - s7_pointer p; sc->sort_body_len = s7_list_length(sc, closure_body(lessp)); - sc->pc = 0; - reset_opts(sc); - for (p = closure_body(lessp); is_pair(cdr(p)); p = cdr(p)) - if (!cell_optimize(sc, p)) - break; - if (is_null(cdr(p))) + if (sc->sort_body_len < 14) { - int32_t start; - start = sc->pc; - if (bool_optimize_nw(sc, p)) - sort_func = (sc->sort_body_len == 2) ? opt_begin_bool_sort_b2 : opt_begin_bool_sort_b; - else + s7_pointer p; + int32_t ctr; + opt_info *top; + sc->pc = 0; + top = alloc_opo(sc, closure_body(lessp)); + for (ctr = SORT_O1, p = closure_body(lessp); is_pair(cdr(p)); ctr++, p = cdr(p)) { - pc_fallback(sc, start); - if (cell_optimize(sc, p)) - sort_func = opt_begin_bool_sort_p; + top->v[ctr].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + } + if (is_null(cdr(p))) + { + int32_t start; + start = sc->pc; + top->v[ctr].o1 = sc->opts[start]; + if (bool_optimize_nw(sc, p)) + sort_func = (sc->sort_body_len == 2) ? opt_begin_bool_sort_b2 : opt_begin_bool_sort_b; + else + { + pc_fallback(sc, start); + if (cell_optimize(sc, p)) + sort_func = opt_begin_bool_sort_p; + } } } } @@ -40101,7 +40205,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); for (p = data, i = 0; i < len; i++, p = cdr(p)) set_car(p, elements[i]); - + sc->v = sc->nil; unstack(sc); /* not pop_stack! */ return(data); } @@ -40176,6 +40280,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) for (i = 0; i < len; i++) chrs[i] = character(elements[i]); } + sc->v = sc->nil; unstack(sc); /* not pop_stack! */ return(data); } @@ -40238,7 +40343,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) for (i = 0; i < len; i++) vector_setter(data)(sc, data, i, elements[i]); /* data is not a typed vector */ - + sc->v = sc->nil; unstack(sc); return(data); } @@ -40322,6 +40427,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) vector_element(lx, 4) = make_mutable_integer(sc, 0); vector_element(lx, 5) = make_integer(sc, n * n); } + sc->v = sc->nil; push_stack(sc, OP_SORT, args, lx); s7_gc_unprotect_at(sc, gc_loc); } @@ -40423,7 +40529,7 @@ static s7_pointer op_heapsort(s7_scheme *sc) SORT_J = j; if (j < n) { - push_stack(sc, OP_SORT1, sc->args, sc->code); + push_stack_direct(sc, OP_SORT1, sc->args, sc->code); lx = SORT_LESSP; /* cadr of sc->args */ if (needs_copied_args(lx)) sc->args = list_2(sc, SORT_DATA(j), SORT_DATA(j + 1)); @@ -40451,7 +40557,7 @@ static bool op_sort1(s7_scheme *sc) j = j + 1; SORT_J = j; } - push_stack(sc, OP_SORT2, sc->args, sc->code); + push_stack_direct(sc, OP_SORT2, sc->args, sc->code); lx = SORT_LESSP; if (needs_copied_args(lx)) sc->args = list_2(sc, SORT_DATA(k), SORT_DATA(j)); @@ -40493,7 +40599,7 @@ static bool op_sort(s7_scheme *sc) { SORT_K = k - 1; SORT_K1 = k - 1; - push_stack(sc, OP_SORT, sc->args, sc->code); + push_stack_direct(sc, OP_SORT, sc->args, sc->code); return(false); } return(true); @@ -40514,7 +40620,7 @@ static bool op_sort3(s7_scheme *sc) SORT_DATA(n) = lx; SORT_N = n - 1; SORT_K1 = 0; - push_stack(sc, OP_SORT3, sc->args, sc->code); + push_stack_direct(sc, OP_SORT3, sc->args, sc->code); return(false); } @@ -40756,7 +40862,7 @@ static s7_int hash_map_closure(s7_scheme *sc, s7_pointer table, s7_pointer key) args = closure_args(f); body = closure_body(f); new_frame_with_slot(sc, closure_let(f), sc->envir, (is_symbol(car(args))) ? car(args) : caar(args), key); - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); if (is_pair(cdr(body))) push_stack_no_args(sc, sc->begin_op, cdr(body)); sc->code = car(body); @@ -41223,7 +41329,7 @@ static hash_entry_t *hash_closure(s7_scheme *sc, s7_pointer table, s7_pointer ke if (hash_entry_raw_hash(x) == hash) { slot_set_value(next_slot(let_slots(sc->envir)), hash_entry_key(x)); - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); if (is_pair(cdr(body))) push_stack_no_args(sc, sc->begin_op, cdr(body)); sc->code = car(body); @@ -42612,7 +42718,7 @@ static s7_pointer g_is_macro(s7_scheme *sc, s7_pointer args) static s7_pointer s7_macroexpand(s7_scheme *sc, s7_pointer mac, s7_pointer args) { - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); sc->code = mac; sc->args = copy_list_with_arglist_error(sc, args); new_frame(sc, closure_let(sc->code), sc->envir); @@ -43598,7 +43704,7 @@ bool s7_is_aritable(s7_scheme *sc, s7_pointer x, s7_int args) { s7_pointer func; if ((has_active_methods(sc, x)) && - ((func = find_method(sc, find_let(sc, x), sc->is_aritable_symbol)) != sc->undefined)) + ((func = find_method_with_let(sc, x, sc->is_aritable_symbol)) != sc->undefined)) return(s7_apply_function(sc, func, list_2(sc, x, s7_make_integer(sc, args))) != sc->F); return(is_safe_procedure(x)); } @@ -44115,7 +44221,7 @@ static s7_pointer bind_symbol_with_setter(s7_scheme *sc, opcode_t op, s7_pointer else { sc->args = list_2(sc, symbol, new_value); - push_stack(sc, op, sc->args, sc->code); + push_stack_direct(sc, op, sc->args, sc->code); sc->code = func; return(sc->no_value); /* this means the setter in set! needs to goto APPLY to get the new value */ } @@ -44388,7 +44494,7 @@ static bool c_objects_are_equal(s7_scheme *sc, s7_pointer a, s7_pointer b, share if (has_active_methods(sc, X)) \ { \ s7_pointer equal_func; \ - equal_func = find_method(Sc, find_let(Sc, X), Sc->is_equivalent_symbol); \ + equal_func = find_method_with_let(Sc, X, Sc->is_equivalent_symbol); \ if (equal_func != Sc->undefined) \ return(s7_boolean(Sc, s7_apply_function(Sc, equal_func, list_2(Sc, X, Y)))); \ }} \ @@ -45961,29 +46067,20 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) { if (is_let(dest)) { - if (has_let_fallback(dest)) + for (i = start; i < end; i++) { - for (i = start; i < end; i++) - { - while (!x) x = elements[++loc]; - if (!is_symbol(hash_entry_key(x))) - return(simple_wrong_type_argument(sc, caller, hash_entry_key(x), T_SYMBOL)); - if ((hash_entry_key(x) != sc->let_ref_fallback_symbol) && - (hash_entry_key(x) != sc->let_set_fallback_symbol)) - make_slot_1(sc, dest, hash_entry_key(x), hash_entry_value(x)); - x = hash_entry_next(x); - } - } - else - { - for (i = start; i < end; i++) - { - while (!x) x = elements[++loc]; - if (!is_symbol(hash_entry_key(x))) - return(simple_wrong_type_argument(sc, caller, hash_entry_key(x), T_SYMBOL)); - make_slot_1(sc, dest, hash_entry_key(x), hash_entry_value(x)); - x = hash_entry_next(x); - } + s7_pointer symbol; + while (!x) x = elements[++loc]; + symbol = hash_entry_key(x); + if (!is_symbol(symbol)) + return(simple_wrong_type_argument(sc, caller, symbol, T_SYMBOL)); + if (is_constant_symbol(sc, symbol)) + return(s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A into ~A: ~A is a constant", 28), caller, dest, symbol))); + if ((symbol != sc->let_ref_fallback_symbol) && + (symbol != sc->let_set_fallback_symbol)) + make_slot_1(sc, dest, symbol, hash_entry_value(x)); + x = hash_entry_next(x); } } else @@ -48160,7 +48257,7 @@ static s7_pointer prepackaged_type_name(s7_scheme *sc, s7_pointer x) if (has_active_methods(sc, x)) { - p = find_method(sc, find_let(sc, x), sc->class_name_symbol); + p = find_method_with_let(sc, x, sc->class_name_symbol); if (is_symbol(p)) return(symbol_name_cell(p)); } @@ -48376,7 +48473,7 @@ s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_p } else { - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); sc->args = sc->nil; new_cell(sc, p, T_DYNAMIC_WIND); @@ -48455,7 +48552,7 @@ static s7_pointer g_catch(s7_scheme *sc, s7_pointer args) if (is_symbol(closure_args(proc))) new_frame_with_slot(sc, closure_let(proc), sc->envir, closure_args(proc), sc->nil); else new_frame(sc, closure_let(proc), sc->envir); - push_stack_no_args(sc, sc->begin_op, T_Pair(sc->code)); + push_stack_no_args_direct(sc, sc->begin_op, T_Pair(sc->code)); } else push_stack(sc, OP_APPLY, sc->nil, proc); @@ -48882,7 +48979,7 @@ static bool catch_dw_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_point dynamic_wind_state(x) = DWIND_FINISH; /* make sure an uncaught error in the exit thunk doesn't cause us to loop */ if (dynamic_wind_out(x) != sc->F) { - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); sc->code = dynamic_wind_out(x); sc->args = sc->nil; eval(sc, OP_APPLY); /* I guess this means no call/cc out of the exit thunk in an error-catching context */ @@ -49349,6 +49446,12 @@ static s7_pointer apply_error(s7_scheme *sc, s7_pointer obj, s7_pointer args) /* the operator type is needed here else the error message is confusing: * (apply '+ (list 1 2))) -> ;attempt to apply + to (1 2)? */ +#if 0 + fprintf(stderr, "code: %s, cur_code: %s\n", display(sc->code), display(sc->cur_code)); + fprintf(stderr, "stack code: %s, args: %s\n", display(stack_code(sc->stack, s7_stack_top(sc) - 1)), display(stack_args(sc->stack, s7_stack_top(sc) - 1))); + /* for op_do, args has useful info on original code + */ +#endif if (is_null(obj)) return(s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, wrap_string(sc, "attempt to apply nil to ~S in ~S?", 33), @@ -49735,7 +49838,7 @@ static bool call_begin_hook(s7_scheme *sc) opcode_t op; op = sc->cur_op; - push_stack(sc, OP_BARRIER, sc->args, sc->code); + push_stack_direct(sc, OP_BARRIER, sc->args, sc->code); sc->begin_hook(sc, &result); if (result) { @@ -49802,7 +49905,7 @@ static s7_pointer g_apply(s7_scheme *sc, s7_pointer args) if (is_null(cdr(args))) { sc->args = sc->nil; - push_stack(sc, OP_APPLY, sc->args, sc->code); + push_stack_direct(sc, OP_APPLY, sc->args, sc->code); return(sc->nil); } @@ -49852,7 +49955,7 @@ s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args) if (is_c_function(fnc)) return(c_function_call(fnc)(sc, args)); - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); sc->code = fnc; sc->args = (needs_copied_args(sc->code)) ? copy_list(sc, args) : args; eval(sc, OP_APPLY); @@ -49954,7 +50057,7 @@ static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indic (c_function_all_args(obj) >= len)) return(c_function_call(obj)(sc, indices)); } - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); sc->code = obj; sc->args = (needs_copied_args(obj)) ? copy_list(sc, indices) : indices; eval(sc, OP_APPLY); @@ -50127,7 +50230,7 @@ s7_pointer s7_apply_function_star(s7_scheme *sc, s7_pointer fnc, s7_pointer args sc->code = sc->z; return(sc->value); } - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); sc->code = fnc; sc->args = (needs_copied_args(sc->code)) ? copy_list(sc, args) : args; eval(sc, OP_APPLY); @@ -50157,7 +50260,7 @@ s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e) } else { - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); sc->code = code; if ((e != sc->rootlet) && (is_let(e))) @@ -50212,7 +50315,7 @@ pass (rootlet):\n\ if (s7_stack_top(sc) < 12) push_stack_op(sc, OP_BARRIER); - push_stack(sc, OP_EVAL, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL, sc->args, sc->code); return(sc->nil); } @@ -50224,7 +50327,7 @@ s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args) set_current_code(sc, history_cons(sc, func, args)); #if SHOW_EVAL_OPS - safe_print(fprintf(stderr, "%s: %s %s\n", __func__, DISPLAY(func), DISPLAY_80(args))); + safe_print(fprintf(stderr, "%s: %s %s\n", __func__, display(func), display_80(args))); #endif if (is_c_function(func)) @@ -50249,7 +50352,7 @@ s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args) if (sc->safety > NO_SAFETY) check_list_validity(sc, "s7_call", args); - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); /* this saves the current evaluation and will eventually finish this (possibly) nested call */ + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); /* this saves the current evaluation and will eventually finish this (possibly) nested call */ sc->code = func; sc->args = (needs_copied_args(func)) ? copy_list(sc, args) : args; /* besides a closure, "func" can also be an object (T_C_OBJECT) -- in Snd, a generator for example */ @@ -50425,10 +50528,10 @@ static void check_let_slots_1(s7_scheme *sc, s7_pointer e, const char* func, s7_ { fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n", func, - DISPLAY(expr), - DISPLAY(var), - DISPLAY(sc->envir), - (tis_slot(let_slots(e))) ? DISPLAY(let_slots(e)) : "no slots"); + display(expr), + display(var), + display(sc->envir), + (tis_slot(let_slots(e))) ? display(let_slots(e)) : "no slots"); if (sc->stop_at_error) abort(); } } @@ -50439,10 +50542,10 @@ static void check_next_let_slot_1(s7_scheme *sc, s7_pointer e, const char* func, { fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n", func, - DISPLAY(expr), - DISPLAY(var), - DISPLAY(e), - (tis_slot(next_slot(let_slots(e)))) ? DISPLAY(next_slot(let_slots(e))) : "no next slot"); + display(expr), + display(var), + display(e), + (tis_slot(next_slot(let_slots(e)))) ? display(next_slot(let_slots(e))) : "no next slot"); if (sc->stop_at_error) abort(); } } @@ -50459,17 +50562,18 @@ static void check_next_let_slot_1(s7_scheme *sc, s7_pointer e, const char* func, /* arg here is the full expression */ static s7_pointer fx_c(s7_scheme *sc, s7_pointer arg) {return(arg);} -static s7_pointer fx_unspecified(s7_scheme *sc, s7_pointer arg) {return(sc->unspecified);} static s7_pointer fx_q(s7_scheme *sc, s7_pointer arg) {return(cadr(arg));} static s7_pointer fx_unsafe_s(s7_scheme *sc, s7_pointer arg) {return(lookup_checked(sc, arg));} static s7_pointer fx_s(s7_scheme *sc, s7_pointer arg) {return(lookup(sc, arg));} static s7_pointer fx_g(s7_scheme *sc, s7_pointer arg) {return((is_global(arg)) ? slot_value(global_slot(arg)) : lookup(sc, arg));} + static s7_pointer fx_t(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, arg); return(slot_value(let_slots(sc->envir))); } + static s7_pointer fx_u(s7_scheme *sc, s7_pointer arg) { check_next_let_slot(sc, __func__, arg, arg); @@ -50481,6 +50585,7 @@ static s7_pointer fx_T(s7_scheme *sc, s7_pointer arg) check_outer_let_slots(sc, __func__, arg, arg); return(slot_value(let_slots(outlet(sc->envir)))); } + static s7_pointer fx_U(s7_scheme *sc, s7_pointer arg) { check_outer_next_let_slot(sc, __func__, arg, arg); @@ -50498,7 +50603,7 @@ static s7_pointer fx_random_i(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_num_eq_xi_1(s7_scheme *sc, s7_pointer args, s7_pointer val, s7_int y) { #if S7_DEBUGGING - if (is_t_integer(val)) fprintf(stderr, "%s[%d]: %s is an integer\n", __func__, __LINE__, DISPLAY(val)); + if (is_t_integer(val)) fprintf(stderr, "%s[%d]: %s is an integer\n", __func__, __LINE__, display(val)); #endif switch (type(val)) { @@ -50601,7 +50706,7 @@ static s7_pointer fx_add_T1(s7_scheme *sc, s7_pointer arg) return(g_add_x1_1(sc, x, cdr(arg))); /* arg=(+ x 1) */ } -static s7_pointer fx_add_U1(s7_scheme *sc, s7_pointer arg) /* sub_t1 was not useful */ +static s7_pointer fx_add_U1(s7_scheme *sc, s7_pointer arg) { s7_pointer x; check_outer_next_let_slot(sc, __func__, arg, cadr(arg)); @@ -50753,12 +50858,12 @@ static s7_pointer fx_is_eq_caar_q(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_not_is_eq_car_q(s7_scheme *sc, s7_pointer arg) { - s7_pointer lst, a; - a = opt2_pair(cdr(arg)); - lst = lookup(sc, opt2_sym(a)); + s7_pointer lst; + /* fprintf(stderr, "%s %s\n", __func__, display(arg)); */ + lst = lookup(sc, opt2_sym(cdr(arg))); if (is_pair(lst)) - return(make_boolean(sc, car(lst) != opt3_any(a))); - return(make_boolean(sc, !s7_is_eq(g_car(sc, set_plist_1(sc, lst)), opt3_any(a)))); + return(make_boolean(sc, car(lst) != opt3_any(cdr(arg)))); + return(make_boolean(sc, !s7_is_eq(g_car(sc, set_plist_1(sc, lst)), opt3_any(cdr(arg))))); } static s7_pointer fx_is_pair_car_s(s7_scheme *sc, s7_pointer arg) @@ -50771,7 +50876,7 @@ static s7_pointer fx_is_pair_car_s(s7_scheme *sc, s7_pointer arg) if (has_active_methods(sc, p)) { s7_pointer func; - func = find_method(sc, p, sc->car_symbol); + func = find_method_with_let(sc, p, sc->car_symbol); if (func != sc->undefined) return(make_boolean(sc, is_pair(s7_apply_function(sc, func, list_1(sc, p))))); } @@ -50911,6 +51016,16 @@ static s7_pointer fx_is_symbol_cadr_t(s7_scheme *sc, s7_pointer arg) return(g_is_symbol(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); } +static s7_pointer fx_is_symbol_car_t(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer val; + check_let_slots(sc, __func__, arg, cadadr(arg)); + val = slot_value(let_slots(sc->envir)); + if (is_pair(val)) + return(make_boolean(sc, is_symbol(car(val)))); + return(make_boolean(sc, is_symbol(g_car(sc, set_plist_1(sc, val))))); +} + static s7_pointer fx_c_s(s7_scheme *sc, s7_pointer arg) { set_car(sc->t1_1, lookup(sc, cadr(arg))); @@ -50950,23 +51065,17 @@ static s7_pointer fx_c_u_direct(s7_scheme *sc, s7_pointer arg) return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, slot_value(next_slot(let_slots(sc->envir))))); } -static s7_pointer fx_o_p_p_s(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_c_s_direct(s7_scheme *sc, s7_pointer arg) { return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)))); } -static s7_pointer fx_o_p_p_t(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_c_t_direct(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, cadr(arg)); return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, slot_value(let_slots(sc->envir)))); } -static s7_pointer fx_o_p_p_u(s7_scheme *sc, s7_pointer arg) -{ - check_next_let_slot(sc, __func__, arg, cadr(arg)); - return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, slot_value(next_slot(let_slots(sc->envir))))); -} - static s7_pointer fx_iterate_p_p(s7_scheme *sc, s7_pointer arg) { s7_pointer iter; @@ -51156,6 +51265,17 @@ static s7_pointer fx_is_symbol_t(s7_scheme *sc, s7_pointer arg) return((is_symbol(slot_value(let_slots(sc->envir)))) ? sc->T : sc->F); } +static s7_pointer fx_is_eof_s(s7_scheme *sc, s7_pointer arg) +{ + return((lookup(sc, cadr(arg)) == eof_object) ? sc->T : sc->F); +} + +static s7_pointer fx_is_eof_t(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadr(arg)); + return((slot_value(let_slots(sc->envir)) == eof_object) ? sc->T : sc->F); +} + static s7_pointer fx_is_type_s(s7_scheme *sc, s7_pointer arg) { return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(lookup(sc, cadr(arg))))); @@ -51167,6 +51287,12 @@ static s7_pointer fx_is_type_t(s7_scheme *sc, s7_pointer arg) return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(slot_value(let_slots(sc->envir))))); } +static s7_pointer fx_is_type_u(s7_scheme *sc, s7_pointer arg) +{ + check_next_let_slot(sc, __func__, arg, cadr(arg)); + return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(slot_value(next_slot(let_slots(sc->envir)))))); +} + static s7_pointer fx_is_integer_s(s7_scheme *sc, s7_pointer arg) { #if WITH_GMP @@ -51295,7 +51421,11 @@ static s7_pointer fx_c_tc(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } -#if (!WITH_GMP) +static s7_pointer fx_c_sc_direct(s7_scheme *sc, s7_pointer arg) +{ + return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg)))); +} + static s7_pointer fx_c_tc_direct(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, cadr(arg)); @@ -51307,7 +51437,6 @@ static s7_pointer fx_vector_ref_direct(s7_scheme *sc, s7_pointer arg) check_let_slots(sc, __func__, arg, cadr(arg)); return(vector_ref_p_pi(sc, slot_value(let_slots(sc->envir)), integer(opt2_con(cdr(arg))))); } -#endif static s7_pointer fx_c_uc(s7_scheme *sc, s7_pointer arg) /* few hits */ { @@ -51365,6 +51494,17 @@ static s7_pointer fx_c_ss(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } +static s7_pointer fx_c_ss_direct(s7_scheme *sc, s7_pointer arg) +{ + return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_c_ts_direct(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadr(arg)); + return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, slot_value(let_slots(sc->envir)), lookup(sc, opt2_sym(cdr(arg))))); +} + static s7_pointer fx_c_st(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, opt2_sym(cdr(arg))); @@ -51381,7 +51521,7 @@ static s7_pointer fx_c_gt(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } -static s7_pointer fx_c_Wt_direct(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_c_Wt_direct(s7_scheme *sc, s7_pointer arg) /* dup */ { s7_pointer old_e, W; old_e = sc->envir; @@ -51419,13 +51559,6 @@ static s7_pointer fx_cons_ts(s7_scheme *sc, s7_pointer arg) return(cons(sc, slot_value(let_slots(sc->envir)), lookup(sc, opt2_sym(cdr(arg))))); } -static s7_pointer fx_cons_tU(s7_scheme *sc, s7_pointer arg) -{ - check_outer_next_let_slot(sc, __func__, arg, opt2_sym(arg)); - check_let_slots(sc, __func__, arg, cadr(arg)); - return(cons(sc, slot_value(let_slots(sc->envir)), slot_value(next_slot(let_slots(outlet(sc->envir)))))); -} - static s7_pointer fx_add_ss(s7_scheme *sc, s7_pointer arg) { return(add_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); @@ -51562,20 +51695,20 @@ static s7_pointer fx_sqr_tt(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_sqr_sqr(s7_scheme *sc, s7_pointer arg) /* tbig -- need t case here */ { set_car(sc->t2_1, fx_sqr_1(sc, lookup(sc, cadr(cadr(arg))))); - set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadr(caddr(arg))))); + set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadaddr(arg)))); return(c_call(arg)(sc, sc->t2_1)); } static s7_pointer fx_c_s_sqr(s7_scheme *sc, s7_pointer arg) /* call */ { set_car(sc->t2_1, lookup(sc, cadr(arg))); - set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadr(caddr(arg))))); + set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadaddr(arg)))); return(c_call(arg)(sc, sc->t2_1)); } static s7_pointer fx_c_c_sqr(s7_scheme *sc, s7_pointer arg) /* fb */ { - set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadr(caddr(arg))))); + set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadaddr(arg)))); set_car(sc->t2_1, cadr(arg)); return(c_call(arg)(sc, sc->t2_1)); } @@ -51591,6 +51724,19 @@ static s7_pointer fx_geq_ts(s7_scheme *sc, s7_pointer arg) return(geq_p_pp(sc, slot_value(let_slots(sc->envir)), lookup(sc, opt2_sym(cdr(arg))))); } +static s7_pointer fx_geq_us(s7_scheme *sc, s7_pointer arg) +{ + check_next_let_slot(sc, __func__, arg, cadr(arg)); + return(geq_p_pp(sc, slot_value(next_slot(let_slots(sc->envir))), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_geq_tT(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadr(arg)); + check_outer_let_slots(sc, __func__, arg, caddr(arg)); + return(geq_p_pp(sc, slot_value(let_slots(sc->envir)), slot_value(let_slots(outlet(sc->envir))))); +} + static s7_pointer fx_geq_tu(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, cadr(arg)); @@ -51964,6 +52110,11 @@ static s7_pointer fx_c_sss(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t3_1)); } +static s7_pointer fx_c_sss_direct(s7_scheme *sc, s7_pointer arg) +{ + return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), lookup(sc, opt1_sym(cdr(arg))), lookup(sc, opt2_sym(cdr(arg))))); +} + static s7_pointer fx_c_tus(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, cadr(arg)); @@ -51982,6 +52133,11 @@ static s7_pointer fx_c_scs(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t3_1)); } +static s7_pointer fx_c_scs_direct(s7_scheme *sc, s7_pointer arg) +{ + return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), opt1_con(cdr(arg)), lookup(sc, opt2_sym(cdr(arg))))); +} + static s7_pointer fx_c_tcs(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, cadr(arg)); @@ -52064,9 +52220,10 @@ static s7_pointer fx_c_opdq_s(s7_scheme *sc, s7_pointer arg) static inline void gc_protect_direct(s7_scheme *sc, s7_pointer val) { + sc->stack_end[2] = val; sc->stack_end[3] = (s7_pointer)OP_GC_PROTECT; sc->stack_end += 4; - sc->stack_end[-2] = val; + /* sc->stack_end[-2] = val; */ } static s7_pointer fx_c_opsq(s7_scheme *sc, s7_pointer arg) @@ -52165,10 +52322,10 @@ static s7_pointer fx_is_type_car_t(s7_scheme *sc, s7_pointer arg) if (is_pair(val)) return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(car(val)))); - if (has_active_methods(sc, val)) + if (has_active_methods(sc, val)) /* this verbosity saves 1/3 total compute time (overhead!) */ { s7_pointer func; - func = find_method(sc, val, sc->car_symbol); + func = find_method_with_let(sc, val, sc->car_symbol); if (func != sc->undefined) return(make_boolean(sc, type(s7_apply_function(sc, func, list_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg)))); } @@ -52185,7 +52342,7 @@ static s7_pointer fx_c_weak1_type_s(s7_scheme *sc, s7_pointer arg) if (has_active_methods(sc, val)) { s7_pointer func; - func = find_method(sc, val, sc->c_pointer_weak1_symbol); + func = find_method_with_let(sc, val, sc->c_pointer_weak1_symbol); if (func != sc->undefined) return(make_boolean(sc, type(s7_apply_function(sc, func, list_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg)))); } @@ -52211,10 +52368,15 @@ static s7_pointer fx_c_opssq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t1_1)); } +static s7_pointer fx_c_opssq_direct(s7_scheme *sc, s7_pointer arg) +{ + return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), lookup(sc, opt1_sym(cdr(arg)))))); +} + static s7_pointer fx_c_optuq(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, cadr(cadr(arg))); - check_next_let_slot(sc, __func__, arg, caddr(cadr(arg))); + check_next_let_slot(sc, __func__, arg, caddadr(arg)); set_car(sc->t2_1, slot_value(let_slots(sc->envir))); set_car(sc->t2_2, slot_value(next_slot(let_slots(sc->envir)))); set_car(sc->t1_1, c_call(cadr(arg))(sc, sc->t2_1)); @@ -52225,8 +52387,8 @@ static s7_pointer fx_c_opstq(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; largs = cadr(arg); - set_car(sc->t2_1, lookup(sc, cadr(largs))); check_let_slots(sc, __func__, arg, caddr(largs)); + set_car(sc->t2_1, lookup(sc, cadr(largs))); set_car(sc->t2_2, slot_value(let_slots(sc->envir))); set_car(sc->t1_1, c_call(largs)(sc, sc->t2_1)); return(c_call(arg)(sc, sc->t1_1)); @@ -52234,9 +52396,21 @@ static s7_pointer fx_c_opstq(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_opstq_direct(s7_scheme *sc, s7_pointer arg) { - return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, - ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadadr(arg)), slot_value(let_slots(sc->envir))))); + return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), slot_value(let_slots(sc->envir))))); +} + +#if (!WITH_GMP) +static s7_pointer fx_is_zero_remainder_1(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer s, t; + check_let_slots(sc, __func__, arg, caddadr(arg)); + s = lookup(sc, opt3_sym(arg)); + t = slot_value(let_slots(sc->envir)); + if ((is_t_integer(s)) && (is_t_integer(t))) + return(make_boolean(sc, c_rem_int(sc, integer(s), integer(t)) == 0)); + return(is_zero_p_p(sc, remainder_p_pp(sc, s, t))); } +#endif static s7_pointer fx_not_opssq(s7_scheme *sc, s7_pointer arg) { @@ -52264,7 +52438,7 @@ static s7_pointer fx_not_oputq(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_not_lt_ut(s7_scheme *sc, s7_pointer arg) { s7_pointer x, y; - check_let_slots(sc, __func__, arg, caddr(cadr(arg))); + check_let_slots(sc, __func__, arg, caddadr(arg)); check_next_let_slot(sc, __func__, arg, cadadr(arg)); y = slot_value(next_slot(let_slots(sc->envir))); x = slot_value(let_slots(sc->envir)); @@ -52330,40 +52504,130 @@ static s7_pointer fx_c_opssq_s(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_opssq_s_direct(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; - largs = cdadr(arg); + largs = opt3_pair(arg); /* cdadr(arg) */ return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg)))); } -static s7_pointer fx_c_opgsq_t_direct(s7_scheme *sc, s7_pointer arg) +#if (!WITH_GMP) +static s7_pointer fx_add_vref_s(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; - largs = cdadr(arg); - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, - ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup_global(sc, car(largs)), lookup(sc, opt2_sym(largs))), - slot_value(let_slots(sc->envir)))); + largs = opt3_pair(arg); /* cdadr(arg) */ + return(add_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg)))); } -static s7_pointer fx_vector_ref_vector_ref_gs_t(s7_scheme *sc, s7_pointer arg) /* ugh! */ +static s7_pointer fx_add_s_vref(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = opt3_pair(arg); /* cdaddr(arg) */ + return(add_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))))); +} + +static s7_pointer fx_subtract_vref_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = opt3_pair(arg); /* cdadr(arg) */ + return(subtract_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg)))); +} + +static s7_pointer fx_subtract_s_vref(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = opt3_pair(arg); /* cdaddr(arg) */ + return(subtract_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))))); +} + +static s7_pointer fx_multiply_s_vref(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = opt3_pair(arg); /* cdaddr(arg) */ + return(multiply_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))))); +} + +static s7_pointer fx_add_mul_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = opt3_pair(arg); /* cdadr(arg) */ + return(add_p_pp(sc, multiply_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg)))); +} + +static s7_pointer fx_gt_add_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = opt3_pair(arg); /* cdadr(arg) */ + return(gt_p_pp(sc, add_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg)))); +} + +static s7_pointer fx_gt_vref_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = opt3_pair(arg); /* cdadr(arg) */ + return(gt_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg)))); +} + +static s7_pointer fx_geq_s_vref(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = opt3_pair(arg); /* cdaddr(arg) */ + return(geq_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))))); +} + +static s7_pointer fx_is_eq_s_vref(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = opt3_pair(arg); /* cdaddr(arg) */ + return(make_boolean(sc, lookup(sc, cadr(arg)) == vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))))); +} + +static s7_pointer fx_vref_s_add(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = opt3_pair(arg); /* cdaddr(arg) */ + return(vector_ref_p_pp(sc, lookup(sc, cadr(arg)), add_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))))); +} +#endif + +static s7_pointer fx_vref_vref_3(s7_scheme *sc, s7_pointer v1, s7_pointer p1, s7_pointer p2) { - s7_pointer p1, p2, v1, v2, largs; - p1 = slot_value(let_slots(sc->envir)); - largs = cdadr(arg); - p2 = lookup(sc, opt2_sym(largs)); - v1 = lookup_global(sc, car(largs)); if ((is_t_integer(p1)) && (is_t_integer(p2)) && ((is_normal_vector(v1)) && (vector_rank(v1) == 1))) { s7_int i1, i2; i1 = integer(p1); i2 = integer(p2); - if ((i1 >= 0) && (i2 >= 0) && (i2 < vector_length(v1))) + if ((i1 >= 0) && (i2 >= 0) && (i1 < vector_length(v1))) { - v2 = vector_element(v1, i2); - if ((is_normal_vector(v2)) && (vector_rank(v2) == 1) && (i1 < vector_length(v2))) - return(vector_element(v2, i1)); + s7_pointer v2; + v2 = vector_element(v1, i1); + if ((is_normal_vector(v2)) && (vector_rank(v2) == 1) && (i2 < vector_length(v2))) + return(vector_element(v2, i2)); }} - return(vector_ref_p_pp(sc, vector_ref_p_pp(sc, v1, p2), p1)); + return(vector_ref_p_pp(sc, vector_ref_p_pp(sc, v1, p1), p2)); +} + +static s7_pointer fx_vref_vref_ss_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = cdadr(arg); + return(fx_vref_vref_3(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs)), lookup(sc, caddr(arg)))); +} + +/* need var3 here */ +static s7_pointer fx_vref_vref_tu_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer slot; + check_let_slots(sc, __func__, arg, cadadr(arg)); + check_next_let_slot(sc, __func__, arg, caddadr(arg)); + slot = let_slots(sc->envir); + return(fx_vref_vref_3(sc, slot_value(slot), slot_value(next_slot(slot)), lookup(sc, caddr(arg)))); +} + +static s7_pointer fx_vref_vref_gs_t(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = cdadr(arg); + return(fx_vref_vref_3(sc, lookup_global(sc, car(largs)), lookup(sc, opt2_sym(largs)), slot_value(let_slots(sc->envir)))); } static s7_pointer fx_c_opscq_c(s7_scheme *sc, s7_pointer arg) @@ -52410,6 +52674,13 @@ static s7_pointer fx_c_opsq_s(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } +static s7_pointer fx_c_opsq_s_direct(s7_scheme *sc, s7_pointer arg) +{ + return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, + ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt1_sym(cdr(arg)))), /* cadadr(arg) */ + lookup(sc, caddr(arg)))); +} + static s7_pointer fx_c_optq_s(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; @@ -52421,6 +52692,14 @@ static s7_pointer fx_c_optq_s(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } +static s7_pointer fx_c_optq_s_direct(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadadr(arg)); + return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, + ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, slot_value(let_slots(sc->envir))), + lookup(sc, caddr(arg)))); +} + static s7_pointer fx_c_opuq_t(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; @@ -52442,11 +52721,18 @@ static s7_pointer fx_c_opuq_t_direct(s7_scheme *sc, s7_pointer arg) slot_value(let_slots(sc->envir)))); } +static s7_pointer fx_cons_opuq_t(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, caddr(arg)); + check_next_let_slot(sc, __func__, arg, cadadr(arg)); + return(cons(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, slot_value(next_slot(let_slots(sc->envir)))), slot_value(let_slots(sc->envir)))); +} + static s7_pointer fx_c_opsq_cs(s7_scheme *sc, s7_pointer arg) { set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg); */ set_car(sc->t3_1, c_call(cadr(arg))(sc, sc->t1_1)); - set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) or cadr(caddr(arg)) */ + set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) or cadaddr(arg) */ set_car(sc->t3_3, lookup(sc, opt2_sym(cdr(arg)))); /* cadddr(arg); */ return(c_call(arg)(sc, sc->t3_1)); } @@ -52527,23 +52813,14 @@ static s7_pointer fx_c_s_opssq(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_s_opssq_direct(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; + largs = opt3_pair(arg); /* cdaddr(arg) */ arg = cdr(arg); - largs = cdadr(arg); return(((s7_p_pp_t)opt2_direct(arg))(sc, lookup(sc, car(arg)), ((s7_p_pp_t)opt3_direct(arg))(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))))); } -/* multiply_s_opssq_direct saved almost nothing */ -static s7_pointer fx_c_g_opgsq_direct(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs; - arg = cdr(arg); - largs = cdadr(arg); - return(((s7_p_pp_t)opt2_direct(arg))(sc, lookup_global(sc, car(arg)), - ((s7_p_pp_t)opt3_direct(arg))(sc, lookup_global(sc, car(largs)), lookup(sc, opt2_sym(largs))))); -} - -static s7_pointer fx_vector_ref_g_vector_ref_gs(s7_scheme *sc, s7_pointer arg) +#if (!WITH_GMP) +static s7_pointer fx_vref_g_vref_gs(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; arg = cdr(arg); @@ -52551,19 +52828,6 @@ static s7_pointer fx_vector_ref_g_vector_ref_gs(s7_scheme *sc, s7_pointer arg) return(vector_ref_p_pp(sc, lookup_global(sc, car(arg)), vector_ref_p_pp(sc, lookup_global(sc, car(largs)), lookup(sc, opt2_sym(largs))))); } - -#if (!WITH_GMP) -static s7_pointer fx_num_eq_add_ss(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs, x, y, z; - largs = cdaddr(arg); - x = lookup(sc, car(largs)); - y = lookup(sc, cadr(largs)); - z = lookup(sc, cadr(arg)); - if ((is_t_integer(x)) && (is_t_integer(y)) && (is_t_integer(z))) - return(make_boolean(sc, (integer(x) + integer(y)) == integer(z))); - return(num_eq_p_pp(sc, z, add_p_pp(sc, x, y))); -} #endif static s7_pointer fx_c_c_opssq(s7_scheme *sc, s7_pointer arg) @@ -52573,19 +52837,21 @@ static s7_pointer fx_c_c_opssq(s7_scheme *sc, s7_pointer arg) set_car(sc->t2_1, lookup(sc, cadr(largs))); set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); set_car(sc->t2_2, c_call(largs)(sc, sc->t2_1)); - set_car(sc->t2_1, cadr(arg)); + set_car(sc->t2_1, cadr(arg)); /* currently (<safe-f> 'a <opssq>) goes to safe_c_ca so this works by inadvertence */ return(c_call(arg)(sc, sc->t2_1)); } -static s7_pointer direct_c_c_opssq(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_c_c_opssq_direct(s7_scheme *sc, s7_pointer arg) +{ + return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, cadr(arg), /* see above */ + ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), lookup(sc, opt1_sym(cdr(arg)))))); +} + +static s7_pointer fx_c_d_opssq_direct(s7_scheme *sc, s7_pointer arg) /* clm2xen (* 1.0 (oscil g2 x2)) */ { - s7_pointer largs; s7_double x2; - arg = cdr(arg); - largs = cdadr(arg); - x2 = ((s7_d_pd_t)opt3_direct(cdr(arg)))(lookup(sc, car(largs)), - real_to_double(sc, lookup(sc, opt2_sym(largs)), "number_to_double")); - return(((s7_p_dd_t)opt2_direct(arg))(sc, real_to_double(sc, car(arg), "*"), x2)); + x2 = ((s7_d_pd_t)opt3_direct(cdr(arg)))(lookup(sc, opt3_sym(arg)), real_to_double(sc, lookup(sc, opt1_sym(cdr(arg))), "number_to_double")); + return(((s7_p_dd_t)opt2_direct(cdr(arg)))(sc, real_to_double(sc, cadr(arg), "*"), x2)); } static s7_pointer fx_c_s_opscq(s7_scheme *sc, s7_pointer arg) @@ -52599,17 +52865,31 @@ static s7_pointer fx_c_s_opscq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } -static s7_pointer fx_c_t_opucq(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_c_s_opscq_direct(s7_scheme *sc, s7_pointer arg) +{ + return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), + ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), opt1_con(cdr(arg))))); +} + +static s7_pointer fx_c_s_opsiq_direct(s7_scheme *sc, s7_pointer arg) +{ + return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), + ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), integer(opt1_con(cdr(arg)))))); +} + +static s7_pointer fx_c_t_opscq_direct(s7_scheme *sc, s7_pointer arg) { - s7_pointer largs; - largs = caddr(arg); check_let_slots(sc, __func__, arg, cadr(arg)); - check_next_let_slot(sc, __func__, arg, cadr(largs)); - set_car(sc->t2_1, slot_value(next_slot(let_slots(sc->envir)))); - set_car(sc->t2_2, opt2_con(cdr(largs))); - set_car(sc->t2_2, c_call(largs)(sc, sc->t2_1)); - set_car(sc->t2_1, slot_value(let_slots(sc->envir))); - return(c_call(arg)(sc, sc->t2_1)); + return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, slot_value(let_slots(sc->envir)), + ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), opt1_con(cdr(arg))))); +} + +static s7_pointer fx_c_t_opucq_direct(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadr(arg)); + check_next_let_slot(sc, __func__, arg, opt3_sym(arg)); + return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, slot_value(let_slots(sc->envir)), + ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, slot_value(next_slot(let_slots(sc->envir))), opt1_con(cdr(arg))))); } static s7_pointer fx_c_s_opsq(s7_scheme *sc, s7_pointer arg) @@ -52631,7 +52911,7 @@ static s7_pointer fx_c_s_opsq_direct(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_t_opuq_direct(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, cadr(arg)); - check_next_let_slot(sc, __func__, arg, cadr(caddr(arg))); + check_next_let_slot(sc, __func__, arg, cadaddr(arg)); arg = cdr(arg); return(((s7_p_pp_t)opt2_direct(arg))(sc, slot_value(let_slots(sc->envir)), ((s7_p_p_t)opt3_direct(arg))(sc, slot_value(next_slot(let_slots(sc->envir)))))); } @@ -52649,14 +52929,14 @@ static s7_pointer fx_c_t_car_u(s7_scheme *sc, s7_pointer arg) { s7_pointer val; check_let_slots(sc, __func__, arg, cadr(arg)); - check_next_let_slot(sc, __func__, arg, cadr(caddr(arg))); + check_next_let_slot(sc, __func__, arg, cadaddr(arg)); val = slot_value(next_slot(let_slots(sc->envir))); set_car(sc->t2_2, (is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); set_car(sc->t2_1, slot_value(let_slots(sc->envir))); return(c_call(arg)(sc, sc->t2_1)); } -static s7_pointer fx_add_s_car_s(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_add_s_car_s(s7_scheme *sc, s7_pointer arg) /* tshoot prime? */ { s7_pointer val1, val2; val2 = lookup(sc, opt2_sym(cdr(arg))); @@ -52682,7 +52962,7 @@ static s7_pointer fx_add_u_car_t(s7_scheme *sc, s7_pointer arg) } #endif -static s7_pointer fx_c_op_s_opsq_q(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_c_op_s_opsqq(s7_scheme *sc, s7_pointer arg) { s7_pointer outer, args; outer = cadr(arg); @@ -52694,7 +52974,18 @@ static s7_pointer fx_c_op_s_opsq_q(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t1_1)); } -static s7_pointer fx_c_op_opsq_s_q(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_not_op_s_opsqq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer outer, args; + outer = cadr(arg); + args = caddr(outer); + set_car(sc->t1_1, lookup(sc, cadr(args))); + set_car(sc->t2_2, c_call(args)(sc, sc->t1_1)); + set_car(sc->t2_1, lookup(sc, cadr(outer))); + return(((c_call(outer)(sc, sc->t2_1)) == sc->F) ? sc->T : sc->F); +} + +static s7_pointer fx_c_op_opsq_sq(s7_scheme *sc, s7_pointer arg) { s7_pointer outer, args; outer = cadr(arg); @@ -52706,6 +52997,19 @@ static s7_pointer fx_c_op_opsq_s_q(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t1_1)); } +static s7_pointer fx_c_op_opsq_cq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer outer, args; + outer = cadr(arg); + args = cadr(outer); + /* fprintf(stderr, "%s %s: outer %s, args %s\n", __func__, display(arg), display(outer), display(args)); */ + set_car(sc->t1_1, lookup(sc, cadr(args))); + set_car(sc->t2_1, c_call(args)(sc, sc->t1_1)); + set_car(sc->t2_2, opt2_con(cdr(outer))); /* caddr(outer)); */ /* opt2_any(...) */ + set_car(sc->t1_1, c_call(outer)(sc, sc->t2_1)); + return(c_call(arg)(sc, sc->t1_1)); +} + static s7_pointer fx_c_c_opsq(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; @@ -52716,16 +53020,6 @@ static s7_pointer fx_c_c_opsq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } -static s7_pointer direct_c_opsq_opsq(s7_scheme *sc, s7_pointer arg) -{ - s7_double x1, x2; - s7_pointer p; - p = cdr(arg); - x1 = ((s7_d_p_t)opt3_direct(p))(lookup(sc, cadar(p))); - x2 = ((s7_d_p_t)opt3_direct(cdr(p)))(lookup(sc, cadadr(p))); - return(((s7_p_dd_t)opt2_direct(p))(sc, x1, x2)); -} - static s7_pointer fx_c_opsq_opsq(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; @@ -52743,6 +53037,15 @@ static s7_pointer fx_c_opsq_opsq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } +static s7_pointer fx_c_opsq_opsq_direct(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = cdr(arg); + return(((s7_p_pp_t)opt3_direct(arg))(sc, + ((s7_p_p_t)opt2_direct(largs))(sc, lookup(sc, cadar(largs))), + ((s7_p_p_t)opt3_direct(largs))(sc, lookup(sc, cadadr(largs))))); +} + static s7_pointer fx_c_opsq_opssq(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; @@ -52807,7 +53110,54 @@ static s7_pointer fx_c_opssq_opssq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } -static s7_pointer fx_c_op_opssq_q_c(s7_scheme *sc, s7_pointer code) +#if (!WITH_GMP) +static s7_pointer fx_sub_mul2(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer a1; + a1 = cdaddr(arg); + sc->u = multiply_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))); + a1 = cdadr(arg); + return(subtract_p_pp(sc, multiply_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))), sc->u)); +} + +static s7_pointer fx_add_mul2(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer a1; + a1 = cdaddr(arg); + sc->u = multiply_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))); + a1 = cdadr(arg); + return(add_p_pp(sc, multiply_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))), sc->u)); +} + +static s7_pointer fx_lt_sub2(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer a1; + a1 = cdaddr(arg); + sc->u = subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))); + a1 = cdadr(arg); + return(lt_p_pp(sc, subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))), sc->u)); +} + +static s7_pointer fx_sub_vref2(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p1, p2, v1, a1; + a1 = cdadr(arg); + v1 = lookup(sc, car(a1)); + p1 = lookup(sc, cadr(a1)); + p2 = lookup(sc, caddaddr(arg)); + if ((is_t_integer(p1)) && (is_t_integer(p2)) && ((is_normal_vector(v1)) && (vector_rank(v1) == 1))) + { + s7_int i1, i2; + i1 = integer(p1); + i2 = integer(p2); + if ((i1 >= 0) && (i1 <= vector_length(v1)) && (i2 >= 0) && (i2 < vector_length(v1))) + return(subtract_p_pp(sc, vector_ref_p_pi(sc, v1, i1), vector_ref_p_pi(sc, v1, i2))); + } + return(subtract_p_pp(sc, vector_ref_p_pp(sc, v1, p1), vector_ref_p_pp(sc, v1, p2))); +} +#endif + +static s7_pointer fx_c_op_opssqq_c(s7_scheme *sc, s7_pointer code) { s7_pointer arg; arg = cadadr(code); @@ -52819,7 +53169,7 @@ static s7_pointer fx_c_op_opssq_q_c(s7_scheme *sc, s7_pointer code) return(c_call(code)(sc, sc->t2_1)); } -static s7_pointer fx_c_op_opsq_q(s7_scheme *sc, s7_pointer code) +static s7_pointer fx_c_op_opsqq(s7_scheme *sc, s7_pointer code) { s7_pointer arg; arg = cadadr(code); @@ -52884,7 +53234,7 @@ static s7_pointer fx_c_s_op_s_opssqq_direct(s7_scheme *sc, s7_pointer code) ((s7_p_pp_t)opt3_direct(cdr(code)))(sc, lookup(sc, cadr(val1)), lookup(sc, caddr(val1)))))); } -static s7_pointer fx_c_op_opsq_q_c(s7_scheme *sc, s7_pointer code) +static s7_pointer fx_c_op_opsqq_c(s7_scheme *sc, s7_pointer code) { s7_pointer arg; arg = cadadr(code); @@ -53034,6 +53384,13 @@ static s7_pointer fx_c_sa(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } +#if 0 +static s7_pointer fx_c_sa(s7_scheme *sc, s7_pointer arg) +{ + /* a -> direct as well? why isn't this already happening? */ +} +#endif + static s7_pointer fx_c_as(s7_scheme *sc, s7_pointer arg) { s7_pointer a1; @@ -53076,7 +53433,7 @@ static s7_pointer fx_multiply_sa(s7_scheme *sc, s7_pointer arg) } #endif -static s7_pointer fx_number_to_string_aa(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_number_to_string_aa(s7_scheme *sc, s7_pointer arg) /* tbig */ { s7_pointer a1, a2; a1 = cdr(arg); @@ -53158,7 +53515,6 @@ static s7_pointer fx_c_opaaq(s7_scheme *sc, s7_pointer arg) set_car(sc->t2_2, fx_call(sc, cddr(p))); set_car(sc->t2_1, sc->stack_end[-2]); sc->stack_end -= 4; - set_car(sc->t1_1, c_call(p)(sc, sc->t2_1)); return(c_call(arg)(sc, sc->t1_1)); } @@ -53291,7 +53647,7 @@ static s7_pointer fx_c_s_opcsq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } -static s7_pointer fx_c_op_opssq_q_s(s7_scheme *sc, s7_pointer code) +static s7_pointer fx_c_op_opssqq_s(s7_scheme *sc, s7_pointer code) { s7_pointer arg; arg = opt1_pair(cdr(code)); @@ -53303,7 +53659,7 @@ static s7_pointer fx_c_op_opssq_q_s(s7_scheme *sc, s7_pointer code) return(c_call(code)(sc, sc->t2_1)); } -static s7_pointer fx_c_op_opssq_q_s_direct(s7_scheme *sc, s7_pointer code) +static s7_pointer fx_c_op_opssqq_s_direct(s7_scheme *sc, s7_pointer code) { s7_pointer arg; arg = opt1_pair(cdr(code)); @@ -53320,7 +53676,7 @@ static s7_pointer fx_c_op_opssq_sq_s(s7_scheme *sc, s7_pointer code) set_car(sc->t2_1, lookup(sc, cadr(arg))); set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(arg)))); set_car(sc->t2_1, c_call(arg)(sc, sc->t2_1)); - set_car(sc->t2_2, lookup(sc, caddr(cadr(code)))); + set_car(sc->t2_2, lookup(sc, caddadr(code))); set_car(sc->t2_1, c_call(cadr(code))(sc, sc->t2_1)); set_car(sc->t2_2, lookup(sc, caddr(code))); return(c_call(code)(sc, sc->t2_1)); @@ -53419,6 +53775,21 @@ static s7_pointer fx_if_a_aa(s7_scheme *sc, s7_pointer arg) return(fx_call(sc, opt2_pair(arg))); } +static s7_pointer fx_if_s_aa(s7_scheme *sc, s7_pointer arg) +{ + if (lookup(sc, cadr(arg)) != sc->F) + return(fx_call(sc, opt1_pair(arg))); + return(fx_call(sc, opt2_pair(arg))); +} + +static s7_pointer fx_if_and2_sa(s7_scheme *sc, s7_pointer arg) +{ + /* fprintf(stderr, "%s, opt1: %s, opt2: %s\n", display(arg), display(opt1_pair(arg)), display(opt2_pair(arg))); */ + if ((fx_call(sc, opt1_pair(arg)) == sc->F) || (fx_call(sc, opt2_pair(arg)) == sc->F)) + return(fx_call(sc, cdddr(arg))); + return(lookup(sc, opt3_sym(arg))); +} + static s7_pointer fx_if_not_a_aa(s7_scheme *sc, s7_pointer arg) { if (is_false(sc, fx_call(sc, opt1_pair(arg)))) @@ -53446,6 +53817,56 @@ static inline s7_pointer fx_and_s_2(s7_scheme *sc, s7_pointer arg) return(c_call(caddr(arg))(sc, sc->t1_1)); } +#if (!WITH_GMP) +static s7_pointer fx_and_or_2_vref(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer or1, arg11, v, ip, jp, xp, arg12; + or1 = cadr(arg); + arg11 = cadr(or1); + v = lookup(sc, cadadr(arg11)); + if ((is_normal_vector(v)) && (vector_rank(v) == 1)) + { + arg12 = caddr(or1); + ip = lookup(sc, caddadr(arg11)); + jp = lookup(sc, caddaddr(arg12)); + if ((is_t_integer(ip)) && (is_t_integer(jp))) + { + s7_int i, j; + i = integer(ip); + j = integer(jp); + if ((i >= 0) && (j >= 0) && + (i < vector_length(v)) && (j < vector_length(v)) && + (is_t_real(vector_element(v, i))) && (is_t_real(vector_element(v, j)))) + { + xp = lookup(sc, caddr(arg11)); + if (is_t_real(xp)) + { + s7_double xf, vi, vj; + vi = real(vector_element(v, i)); + vj = real(vector_element(v, j)); + xf = real(xp); + return(make_boolean(sc, ((vi > xf) || (xf >= vj)) && ((vj > xf) || (xf >= vi)))); + }}}} + return(fx_and_2(sc, arg)); +} +#endif + +static s7_pointer fx_len2(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer val; + check_let_slots(sc, __func__, arg, cadadr(arg)); + val = slot_value(let_slots(sc->envir)); + return(make_boolean(sc, is_pair(val) && (is_pair(cdr(val))) && (is_null(cddr(val))))); +} + +static s7_pointer fx_len3(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer val; + check_let_slots(sc, __func__, arg, cadadr(arg)); + val = slot_value(let_slots(sc->envir)); + return(make_boolean(sc, is_pair(val) && (is_pair(cdr(val))) && (is_pair(cddr(val))))); +} + static s7_pointer fx_and_3(s7_scheme *sc, s7_pointer arg) { s7_pointer p, val; @@ -53496,13 +53917,20 @@ static s7_pointer fx_or_s_type_2(s7_scheme *sc, s7_pointer arg) return(make_boolean(sc, (type(x) == integer(opt3_any(arg))) || (type(x) == integer(opt2_any(cdr(arg)))))); } +static s7_pointer fx_not_symbol_or_keyword(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer val; + val = lookup(sc, opt3_sym(arg)); + return(make_boolean(sc, (!is_symbol(val)) || (is_keyword(val)))); +} + static s7_pointer fx_or_and_2(s7_scheme *sc, s7_pointer arg) { s7_pointer p, val; p = cdr(arg); val = fx_call(sc, p); if (val != sc->F) return(val); - p = cdadr(p); + p = opt3_pair(arg); /* cdadr(p); */ val = fx_call(sc, p); if (val == sc->F) return(val); return(fx_call(sc, cdr(p))); @@ -53514,7 +53942,7 @@ static s7_pointer fx_or_and_3(s7_scheme *sc, s7_pointer arg) p = cdr(arg); val = fx_call(sc, p); if (val != sc->F) return(val); - p = cdadr(p); + p = opt3_pair(arg); /* cdadr(p); */ val = fx_call(sc, p); if (val == sc->F) return(val); p = cdr(p); @@ -53583,8 +54011,6 @@ static s7_pointer fx_safe_closure_t_a(s7_scheme *sc, s7_pointer code) return(result); } -static s7_pointer fx_safe_closure_id_s(s7_scheme *sc, s7_pointer arg) {return(lookup(sc, opt2_sym(arg)));} - static s7_pointer fx_safe_closure_s_to_s(s7_scheme *sc, s7_pointer arg) { set_car(sc->t1_1, lookup(sc, opt2_sym(arg))); @@ -53598,51 +54024,11 @@ static s7_pointer fx_safe_closure_s_to_sc(s7_scheme *sc, s7_pointer arg) return(c_call(car(closure_body(opt1_lambda(arg))))(sc, sc->t2_1)); } -static s7_pointer fx_c_closure_s_a(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_safe_closure_a_to_sc(s7_scheme *sc, s7_pointer arg) { - s7_pointer clo_arg; - clo_arg = cadr(arg); - gc_protect_direct(sc, sc->envir); - sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(clo_arg)), lookup(sc, opt2_sym(clo_arg))); - set_car(sc->t1_1, fx_call(sc, closure_body(opt1_lambda(clo_arg)))); - sc->envir = sc->stack_end[-2]; - sc->stack_end -= 4; - return(c_call(arg)(sc, sc->t1_1)); -} - -static s7_pointer fx_safe_closure_s_d(s7_scheme *sc, s7_pointer code) -{ - s7_pointer result; - gc_protect_direct(sc, sc->envir); - sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))); - result = d_call(sc, car(closure_body(opt1_lambda(code)))); - sc->envir = sc->stack_end[-2]; - sc->stack_end -= 4; - return(result); -} - -static s7_pointer fx_safe_closure_t_d(s7_scheme *sc, s7_pointer code) -{ - s7_pointer result; - check_let_slots(sc, __func__, code, opt2_sym(code)); - gc_protect_direct(sc, sc->envir); - sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(code)), slot_value(let_slots(sc->envir))); - result = d_call(sc, car(closure_body(opt1_lambda(code)))); - sc->envir = sc->stack_end[-2]; - sc->stack_end -= 4; - return(result); -} - -static s7_pointer fx_c_closure_s_d(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer clo_arg; - clo_arg = cadr(arg); - gc_protect_direct(sc, sc->envir); - sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(clo_arg)), lookup(sc, opt2_sym(clo_arg))); - set_car(sc->t1_1, d_call(sc, car(closure_body(opt1_lambda(clo_arg))))); - sc->envir = sc->stack_end[-2]; - sc->stack_end -= 4; - return(c_call(arg)(sc, sc->t1_1)); + set_car(sc->t2_1, fx_call(sc, cdr(arg))); + set_car(sc->t2_2, opt3_any(cdr(arg))); + return(c_call(car(closure_body(opt1_lambda(arg))))(sc, sc->t2_1)); } static s7_pointer fx_and_2_closure_s(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is fx_and_2 */ @@ -53696,6 +54082,17 @@ static s7_pointer fx_safe_closure_ss_a(s7_scheme *sc, s7_pointer code) return(result); } +static s7_pointer fx_safe_closure_3s_a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer result; + gc_protect_direct(sc, sc->envir); + sc->envir = old_frame_with_three_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code))); + result = fx_call(sc, closure_body(opt1_lambda(code))); + sc->envir = sc->stack_end[-2]; + sc->stack_end -= 4; + return(result); +} + /* fx_c_s b, dx_c+fx_cdr_s->fx_tc_if_a_laa_z lg */ static s7_pointer fx_safe_closure_aa_a(s7_scheme *sc, s7_pointer code) { @@ -53727,189 +54124,8 @@ static inline s7_pointer fx_cond_fx_fx(s7_scheme *sc, s7_pointer code) /* all t return(sc->unspecified); } -static s7_pointer fx_tc_and_a_or_a_la(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_or_a_and_a_la(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_or_a_a_and_a_a_la(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_or_a_and_a_laa(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_if_a_z_la(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_if_a_la_z(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_if_a_z_laa(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_if_a_laa_z(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_if_a_z_if_a_la_z(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_if_a_z_if_a_z_laa(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_if_a_z_if_a_laa_z(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_cond_a_z_a_z_laa(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_case_la(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_or_a_and_a_a_l3a(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_if_a_t_and_a_a_l3a(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_let_when_laa(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_let_unless_laa(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_let_cond(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer arg); - -static s7_pointer fx_recur_if_a_a_and_a_laa_laa(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_recur_if_a_a_opa_laq(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_recur_if_a_opa_laq_a(s7_scheme *sc, s7_pointer arg); -static s7_pointer fx_recur_cond_a_a_a_a_opla_laq(s7_scheme *sc, s7_pointer arg); - -static s7_pointer fx_opif_a_ssq_a(s7_scheme *sc, s7_pointer code); - static s7_function fx_function[NUM_OPS]; -static void fx_function_init(void) -{ - int32_t i; - for (i = 0; i < NUM_OPS; i++) - fx_function[i] = NULL; - - fx_function[HOP_SAFE_C_D] = fx_c_d; - - fx_function[HOP_SAFE_C_S] = fx_c_s; - fx_function[HOP_SAFE_C_opDq] = fx_c_opdq; - fx_function[HOP_SAFE_C_opSq] = fx_c_opsq; - fx_function[HOP_SAFE_C_opSSq] = fx_c_opssq; - fx_function[HOP_SAFE_C_opSCq] = fx_c_opscq; - fx_function[HOP_SAFE_C_opCSq] = fx_c_opcsq; - - fx_function[HOP_SAFE_C_SC] = fx_c_sc; - fx_function[HOP_SAFE_C_CS] = fx_c_cs; - fx_function[HOP_SAFE_C_CQ] = fx_c_cq; - fx_function[HOP_SAFE_C_SS] = fx_c_ss; - - fx_function[HOP_SAFE_C_opSq_S] = fx_c_opsq_s; - fx_function[HOP_SAFE_C_opSq_C] = fx_c_opsq_c; - fx_function[HOP_SAFE_C_opSq_CS] = fx_c_opsq_cs; - fx_function[HOP_SAFE_C_S_opSq] = fx_c_s_opsq; - fx_function[HOP_SAFE_C_S_opDq] = fx_c_s_opdq; - fx_function[HOP_SAFE_C_opDq_S] = fx_c_opdq_s; - fx_function[HOP_SAFE_C_C_opSq] = fx_c_c_opsq; - fx_function[HOP_SAFE_C_C_opDq] = fx_c_c_opdq; - fx_function[HOP_SAFE_C_opCSq_C] = fx_c_opcsq_c; - fx_function[HOP_SAFE_C_opCSq_S] = fx_c_opcsq_s; - fx_function[HOP_SAFE_C_C_opCSq] = fx_c_c_opcsq; - fx_function[HOP_SAFE_C_S_opCSq] = fx_c_s_opcsq; - fx_function[HOP_SAFE_C_opSSq_C] = fx_c_opssq_c; - fx_function[HOP_SAFE_C_opSCq_C] = fx_c_opscq_c; - fx_function[HOP_SAFE_C_opSSq_S] = fx_c_opssq_s; - fx_function[HOP_SAFE_C_S_opSSq] = fx_c_s_opssq; - fx_function[HOP_SAFE_C_C_opSSq] = fx_c_c_opssq; - fx_function[HOP_SAFE_C_S_opSCq] = fx_c_s_opscq; - fx_function[HOP_SAFE_C_C_opSCq] = fx_c_c_opscq; - fx_function[HOP_SAFE_C_opSq_opSq] = fx_c_opsq_opsq; - fx_function[HOP_SAFE_C_opSq_opSSq] = fx_c_opsq_opssq; - fx_function[HOP_SAFE_C_opSSq_opSq] = fx_c_opssq_opsq; - fx_function[HOP_SAFE_C_opSSq_opSSq] = fx_c_opssq_opssq; - fx_function[HOP_SAFE_C_op_opSSq_q_C] = fx_c_op_opssq_q_c; - fx_function[HOP_SAFE_C_op_opSq_q] = fx_c_op_opsq_q; - fx_function[HOP_SAFE_C_op_opSq_q_C] = fx_c_op_opsq_q_c; - fx_function[HOP_SAFE_C_op_S_opSq_q] = fx_c_op_s_opsq_q; - fx_function[HOP_SAFE_C_op_opSq_S_q] = fx_c_op_opsq_s_q; - fx_function[HOP_SAFE_C_S_op_S_opSqq] = fx_c_s_op_s_opsqq; - fx_function[HOP_SAFE_C_S_op_S_opSSqq] = fx_c_s_op_s_opssqq; - fx_function[HOP_SAFE_C_S_op_opSq_Cq] = fx_c_s_op_opsq_cq; - fx_function[HOP_SAFE_C_op_opSSq_q_S] = fx_c_op_opssq_q_s; - fx_function[HOP_SAFE_C_op_opSSq_Sq_S] = fx_c_op_opssq_sq_s; - fx_function[HOP_SAFE_C_S_op_opSSq_opSSqq] = fx_c_s_op_opssq_opssqq; - - fx_function[OP_SAFE_C_TUS] = fx_c_tus; - fx_function[HOP_SAFE_C_SSC] = fx_c_ssc; - fx_function[HOP_SAFE_C_SSS] = fx_c_sss; - fx_function[HOP_SAFE_C_SCS] = fx_c_scs; - fx_function[HOP_SAFE_C_SCC] = fx_c_scc; - fx_function[HOP_SAFE_C_CSS] = fx_c_css; - fx_function[HOP_SAFE_C_CSC] = fx_c_csc; - fx_function[HOP_SAFE_C_CCS] = fx_c_ccs; - fx_function[HOP_SAFE_C_ALL_S] = fx_c_all_s; - - fx_function[HOP_SAFE_C_A] = fx_c_a; - fx_function[HOP_SAFE_C_AA] = fx_c_aa; - fx_function[HOP_SAFE_C_CA] = fx_c_ca; - fx_function[HOP_SAFE_C_AC] = fx_c_ac; - fx_function[HOP_SAFE_C_AAA] = fx_c_aaa; - fx_function[HOP_SAFE_C_CAC] = fx_c_cac; - fx_function[HOP_SAFE_C_CSA] = fx_c_csa; - fx_function[HOP_SAFE_C_SCA] = fx_c_sca; - fx_function[HOP_SAFE_C_SAS] = fx_c_sas; - fx_function[HOP_SAFE_C_SSA] = fx_c_ssa; - fx_function[HOP_SAFE_C_ALL_CA] = fx_c_all_ca; - fx_function[HOP_SAFE_C_FX] = fx_c_fx; - fx_function[HOP_SAFE_C_4A] = fx_c_4a; - fx_function[HOP_SAFE_C_opAq] = fx_c_opaq; - fx_function[HOP_SAFE_C_opAAq] = fx_c_opaaq; - fx_function[HOP_SAFE_C_opAAAq] = fx_c_opaaaq; - fx_function[HOP_SAFE_C_opAq_S] = fx_c_opaq_s; - fx_function[HOP_SAFE_C_S_opAq] = fx_c_s_opaq; - fx_function[HOP_SAFE_C_S_opAAq] = fx_c_s_opaaq; - fx_function[HOP_SAFE_C_S_opAAAq] = fx_c_s_opaaaq; - - fx_function[HOP_SAFE_THUNK_A] = fx_safe_thunk_a; - fx_function[HOP_SAFE_CLOSURE_S_A] = fx_safe_closure_s_a; - fx_function[HOP_SAFE_CLOSURE_A_A] = fx_safe_closure_a_a; - fx_function[HOP_SAFE_CLOSURE_SS_A] = fx_safe_closure_ss_a; - fx_function[HOP_SAFE_CLOSURE_AA_A] = fx_safe_closure_aa_a; - - fx_function[OP_SSA_DIRECT] = fx_c_ssa_direct; - fx_function[OP_HASH_INCREMENT] = fx_hash_increment; - - fx_function[HOP_SAFE_CLOSURE_ID_S] = fx_safe_closure_id_s; - - fx_function[HOP_SAFE_CLOSURE_S_TO_S] = fx_safe_closure_s_to_s; - fx_function[HOP_SAFE_CLOSURE_S_TO_SC] = fx_safe_closure_s_to_sc; - - fx_function[OP_COND_FX_FX] = fx_cond_fx_fx; - fx_function[OP_opIF_A_SSq_A] = fx_opif_a_ssq_a; - fx_function[OP_IF_A_CC] = fx_if_a_cc; - fx_function[OP_IF_A_A] = fx_if_a_a; - fx_function[OP_IF_A_AA] = fx_if_a_aa; - fx_function[OP_IF_NOT_A_A] = fx_if_not_a_a; - fx_function[OP_IF_NOT_A_AA] = fx_if_not_a_aa; - fx_function[OP_OR_2] = fx_or_2; - fx_function[OP_OR_S_2] = fx_or_s_2; - fx_function[OP_OR_S_TYPE_2] = fx_or_s_type_2; - fx_function[OP_OR_3] = fx_or_3; - fx_function[OP_OR_N] = fx_or_n; - fx_function[OP_AND_2] = fx_and_2; - fx_function[OP_AND_S_2] = fx_and_s_2; - fx_function[OP_AND_3] = fx_and_3; - fx_function[OP_AND_N] = fx_and_n; - - fx_function[OP_SYM] = fx_unsafe_s; /* these 4 probably never happen */ - fx_function[OP_GLOBAL_SYM] = fx_g; - fx_function[OP_CON] = fx_c; - fx_function[OP_UNSPECIFIED] = fx_unspecified; - - fx_function[OP_TC_AND_A_OR_A_LA] = fx_tc_and_a_or_a_la; - fx_function[OP_TC_OR_A_AND_A_LA] = fx_tc_or_a_and_a_la; - fx_function[OP_TC_OR_A_A_AND_A_A_LA] = fx_tc_or_a_a_and_a_a_la; - fx_function[OP_TC_AND_A_OR_A_LAA] = fx_tc_and_a_or_a_laa; - fx_function[OP_TC_OR_A_AND_A_LAA] = fx_tc_or_a_and_a_laa; - fx_function[OP_TC_IF_A_Z_LA] = fx_tc_if_a_z_la; - fx_function[OP_TC_IF_A_LA_Z] = fx_tc_if_a_la_z; - fx_function[OP_TC_IF_A_Z_LAA] = fx_tc_if_a_z_laa; - fx_function[OP_TC_IF_A_LAA_Z] = fx_tc_if_a_laa_z; - fx_function[OP_TC_IF_A_Z_IF_A_Z_LA] = fx_tc_if_a_z_if_a_z_la; - fx_function[OP_TC_IF_A_Z_IF_A_LA_Z] = fx_tc_if_a_z_if_a_la_z; - fx_function[OP_TC_IF_A_Z_IF_A_Z_LAA] = fx_tc_if_a_z_if_a_z_laa; - fx_function[OP_TC_IF_A_Z_IF_A_LAA_Z] = fx_tc_if_a_z_if_a_laa_z; - fx_function[OP_TC_COND_A_Z_A_Z_LAA] = fx_tc_cond_a_z_a_z_laa; - fx_function[OP_TC_CASE_LA] = fx_tc_case_la; - fx_function[OP_TC_OR_A_AND_A_A_L3A] = fx_tc_or_a_and_a_a_l3a; - fx_function[OP_TC_IF_A_T_AND_A_A_L3A] = fx_tc_if_a_t_and_a_a_l3a; - fx_function[OP_TC_LET_IF_A_Z_LAA] = fx_tc_let_if_a_z_laa; - fx_function[OP_TC_LET_WHEN_LAA] = fx_tc_let_when_laa; - fx_function[OP_TC_LET_UNLESS_LAA] = fx_tc_let_unless_laa; - fx_function[OP_TC_LET_COND] = fx_tc_let_cond; - fx_function[OP_TC_COND_A_Z_A_LAA_LAA] = fx_tc_cond_a_z_a_laa_laa; - - fx_function[OP_RECUR_IF_A_A_opA_LAq] = fx_recur_if_a_a_opa_laq; - fx_function[OP_RECUR_IF_A_opA_LAq_A] = fx_recur_if_a_opa_laq_a; - fx_function[OP_RECUR_IF_A_A_AND_A_LAA_LAA] = fx_recur_if_a_a_and_a_laa_laa; - fx_function[OP_RECUR_COND_A_A_A_A_opLA_LAq] = fx_recur_cond_a_a_a_a_opla_laq; -} - static bool is_fxable(s7_scheme *sc, s7_pointer p) { if (!is_pair(p)) return(true); @@ -53940,12 +54156,16 @@ static inline s7_pointer check_quote(s7_scheme *sc, s7_pointer code); static s7_p_p_t s7_p_p_function(s7_pointer f); static s7_p_pp_t s7_p_pp_function(s7_pointer f); static s7_p_ppp_t s7_p_ppp_function(s7_pointer f); +static s7_p_dd_t s7_p_dd_function(s7_pointer f); +static s7_p_pi_t s7_p_pi_function(s7_pointer f); + +#define is_global_and_has_func(P, Func) ((is_global(P)) && (Func(slot_value(global_slot(P))))) static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, safe_sym_t *checker) { s7_pointer arg; arg = car(holder); - /* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, DISPLAY(arg), op_names[optimize_op(arg)]); */ + /* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(arg), op_names[optimize_op(arg)]); */ if (!is_pair(arg)) { @@ -53956,7 +54176,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf (is_global(arg)))) return(fx_c); #if S7_DEBUGGING - if ((is_global(arg)) && (!checker(sc, arg, e))) fprintf(stderr, "%s global: %d\n", DISPLAY(arg), checker(sc, arg, e)); + if ((is_global(arg)) && (!checker(sc, arg, e))) fprintf(stderr, "%s global: %d\n", display(arg), checker(sc, arg, e)); #endif if (is_global(arg)) return(fx_g); @@ -53978,10 +54198,39 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf return(fx_c_d); case OP_OR_2: - if (c_callee(cddr(arg)) == fx_and_2) return(fx_or_and_2); - if (c_callee(cddr(arg)) == fx_and_3) return(fx_or_and_3); + if (c_callee(cddr(arg)) == fx_and_2) {set_opt3_pair(arg, cdaddr(arg)); return(fx_or_and_2);} + if (c_callee(cddr(arg)) == fx_and_3) {set_opt3_pair(arg, cdaddr(arg)); return(fx_or_and_3);} + if ((c_callee(cdr(arg)) == fx_not_is_symbol_s) && (c_callee(cddr(arg)) == fx_is_keyword_s) && (cadr(cadadr(arg)) == cadaddr(arg))) + { + /* (or (not (symbol? body)) (keyword? body)) */ + set_opt3_sym(arg, cadaddr(arg)); + return(fx_not_symbol_or_keyword); + } return(fx_or_2); - + +#if (!WITH_GMP) + case OP_AND_2: + if ((c_callee(cdr(arg)) == fx_or_2) && (c_callee(cddr(arg)) == fx_or_2)) + { + s7_pointer o1, o2, i, j, v, x; + o1 = cadr(arg); + o2 = caddr(arg); + if ((c_callee(cdr(o1)) == fx_gt_vref_s) && (c_callee(cddr(o1)) == fx_geq_s_vref) && (c_callee(cdr(o2)) == fx_gt_vref_s) && (c_callee(cddr(o2)) == fx_geq_s_vref)) + { + v = cadr(cadadr(o1)); + if ((v == cadr(cadadr(o2))) && (v == (cadr(caddaddr(o1)))) && (v == (cadr(caddaddr(o2))))) + { + x = caddadr(o1); + if ((x == caddadr(o2)) && (x == cadr(caddr(o1))) && (x == cadr(caddr(o2)))) + { + i = caddr(cadadr(o1)); + j = caddaddr(caddr(o1)); + if ((j == caddr(cadadr(o2))) && (i == caddaddr(caddr(o2)))) + return(fx_and_or_2_vref); + }}}} + return(fx_and_2); +#endif + case HOP_SAFE_C_S: if (car(arg) == sc->cdr_symbol) return(fx_cdr_s); if (car(arg) == sc->car_symbol) return(fx_car_s); @@ -53992,6 +54241,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf if (car(arg) == sc->is_null_symbol) return(fx_is_null_s); if (car(arg) == sc->is_pair_symbol) return(fx_is_pair_s); if (car(arg) == sc->is_symbol_symbol) return(fx_is_symbol_s); + if (car(arg) == sc->is_eof_object_symbol) return(fx_is_eof_s); if (car(arg) == sc->is_integer_symbol) return(fx_is_integer_s); if (car(arg) == sc->is_string_symbol) return(fx_is_string_s); if (car(arg) == sc->not_symbol) return(fx_not_s); @@ -54007,7 +54257,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf return(fx_is_type_s); } } - if (symbol_id(car(arg)) == 0) + if ((symbol_id(car(arg)) == 0) && (is_slot(global_slot(car(arg))))) { /* car_p_p (et al) does not look for a method so in: * (define kar car) (load "mockery.scm") (let ((p (mock-pair '(1 2 3)))) (call-with-exit (lambda (x) (x (kar p))))) @@ -54019,11 +54269,8 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf f = s7_p_p_function(slot_value(global_slot(car(arg)))); if (f) { - set_direct_opt(arg); set_opt2_direct(cdr(arg), (s7_pointer)f); - if (f == iterate_p_p) - return(fx_iterate_p_p); - return(fx_o_p_p_s); + return((f == iterate_p_p) ? fx_iterate_p_p : fx_c_s_direct); } } } @@ -54047,22 +54294,51 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf if ((c_callee(arg) == g_hash_table_ref_2) && (is_symbol(car(arg))) && (is_symbol(cadr(arg)))) return(fx_hash_table_ref_ss); + + if (is_global_and_has_func(car(arg), s7_p_pp_function)) + { + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); + return(fx_c_ss_direct); + } return(fx_c_ss); + + case HOP_SAFE_C_opSq_S: + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(caadr(arg), s7_p_p_function))) + { + set_opt1_sym(cdr(arg), cadadr(arg)); + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(arg)))))); + return(fx_c_opsq_s_direct); + } + return(fx_c_opsq_s); -#if (!WITH_GMP) case HOP_SAFE_C_SSS: +#if (!WITH_GMP) if ((c_callee(arg) == g_less) && (is_global(cadr(arg))) && (is_global(cadddr(arg)))) return(fx_lt_gsg); - return(fx_c_sss); #endif + if (is_global_and_has_func(car(arg), s7_p_ppp_function)) + { + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(slot_value(global_slot(car(arg)))))); + return(fx_c_sss_direct); + } + return(fx_c_sss); case HOP_SAFE_C_SSA: - if (s7_p_ppp_function(slot_value(global_slot(car(arg))))) + if (is_global_and_has_func(car(arg), s7_p_ppp_function)) { - set_direct_opt(arg); set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(slot_value(global_slot(car(arg)))))); return(fx_c_ssa_direct); } return(fx_c_ssa); + + case HOP_SAFE_C_SCS: + if (is_global_and_has_func(car(arg), s7_p_ppp_function)) + { + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(slot_value(global_slot(car(arg)))))); + return(fx_c_scs_direct); + } + return(fx_c_scs); case HOP_SAFE_C_AAA: if ((c_callee(cdr(arg)) == fx_g) && (c_callee(cdddr(arg)) == fx_c)) return(fx_c_gac); @@ -54086,41 +54362,45 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf s2 = caddr(arg); if ((car(s2) == sc->multiply_symbol) && (cadr(s2) == caddr(s2))) return(fx_c_s_sqr); - - if ((car(arg) == sc->num_eq_symbol) && (car(s2) == sc->add_symbol)) - return(fx_num_eq_add_ss); } #endif - if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) && - (s7_p_pp_function(slot_value(global_slot(caaddr(arg)))))) + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(caaddr(arg), s7_p_pp_function))) { - set_direct_opt(arg); set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(arg)))))); - /* tbig: (* wr (vector-ref|float-vector-ref|int-vector-ref|hash-table-ref|let-ref rl j)) - * (+ ii (* pw mmax)) - * b: (vref s (vref...)) (-|+ s (* s s)) - */ - if ((is_global(cadr(arg))) && (is_global(cadr(caddr(arg))))) - { - if ((opt2_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp) && - (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) - return(fx_vector_ref_g_vector_ref_gs); - return(fx_c_g_opgsq_direct); - } - /* if (opt2_direct(cdr(arg)) == (s7_pointer)multiply_p_pp) return(fx_multiply_s_opssq_direct); */ /* very small gain */ + set_opt3_pair(arg, cdaddr(arg)); +#if (!WITH_GMP) + if ((is_global(cadr(arg))) && (is_global(cadaddr(arg))) && + (opt2_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) + return(fx_vref_g_vref_gs); + if ((opt2_direct(cdr(arg)) == (s7_pointer)add_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_add_s_vref); + if ((opt2_direct(cdr(arg)) == (s7_pointer)subtract_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_subtract_s_vref); + if ((opt2_direct(cdr(arg)) == (s7_pointer)multiply_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_multiply_s_vref); + if ((opt2_direct(cdr(arg)) == (s7_pointer)geq_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_geq_s_vref); + if ((opt2_direct(cdr(arg)) == (s7_pointer)is_eq_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_is_eq_s_vref); + if ((opt2_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)add_p_pp)) return(fx_vref_s_add); +#endif return(fx_c_s_opssq_direct); } return(fx_c_s_opssq); - + case HOP_SAFE_C_opSSq_S: - if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) && - (s7_p_pp_function(slot_value(global_slot(caadr(arg)))))) + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(caadr(arg), s7_p_pp_function))) { /* op_c_opgsq_t */ - set_direct_opt(arg); set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caadr(arg)))))); + set_opt3_pair(arg, cdadr(arg)); +#if (!WITH_GMP) + if ((opt2_direct(cdr(arg)) == (s7_pointer)add_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_add_vref_s); + if ((opt2_direct(cdr(arg)) == (s7_pointer)add_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)multiply_p_pp)) return(fx_add_mul_s); + if ((opt2_direct(cdr(arg)) == (s7_pointer)gt_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)add_p_pp)) return(fx_gt_add_s); + if ((opt2_direct(cdr(arg)) == (s7_pointer)subtract_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_subtract_vref_s); + if ((opt2_direct(cdr(arg)) == (s7_pointer)gt_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_gt_vref_s); + if ((opt2_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_vref_vref_ss_s); +#endif return(fx_c_opssq_s_direct); } return(fx_c_opssq_s); @@ -54131,9 +54411,14 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf s7_pointer s1, s2; s1 = cadr(arg); s2 = caddr(arg); - if ((car(s1) == sc->multiply_symbol) && (cadr(s1) == caddr(s1)) && - (car(s2) == sc->multiply_symbol) && (cadr(s2) == caddr(s2))) - return(fx_c_sqr_sqr); + if ((car(s1) == sc->multiply_symbol) && (car(s2) == sc->multiply_symbol)) + { + if ((cadr(s1) == caddr(s1)) && (cadr(s2) == caddr(s2))) return(fx_c_sqr_sqr); + if (car(arg) == sc->subtract_symbol) return(fx_sub_mul2); + if (car(arg) == sc->add_symbol) return(fx_add_mul2); + } + if ((car(arg) == sc->lt_symbol) && (car(s1) == sc->subtract_symbol) && (car(s2) == sc->subtract_symbol)) return(fx_lt_sub2); + if ((car(arg) == sc->subtract_symbol) && (car(s1) == sc->vector_ref_symbol) && (car(s2) == sc->vector_ref_symbol) && (cadr(s1) == cadr(s2))) return(fx_sub_vref2); return(fx_c_opssq_opssq); } #endif @@ -54260,6 +54545,16 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf #endif if ((c_callee(arg) == g_memq_2) && (is_pair(caddr(arg)))) return(fx_memq_sq_2); if ((c_callee(arg) == g_is_eq) && (!is_unspecified(caddr(arg)))) return(fx_is_eq_sc); + +#if (!WITH_GMP) + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && (c_callee(arg) != g_divide_by_2)) +#else + if (is_global_and_has_func(car(arg), s7_p_pp_function)) +#endif + { + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); + return(fx_c_sc_direct); + } return(fx_c_sc); case HOP_SAFE_C_CS: @@ -54279,19 +54574,18 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf { if (car(arg) == sc->hash_table_ref_symbol) { - set_opt2_sym(cdr(arg), cadr(caddr(arg))); + set_opt2_sym(cdr(arg), cadaddr(arg)); return(fx_hash_table_ref_car); } - set_opt2_sym(cdr(arg), cadr(caddr(arg))); + set_opt2_sym(cdr(arg), cadaddr(arg)); if (car(arg) == sc->add_symbol) return(fx_add_s_car_s); return(fx_c_s_car_s); } - if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) && - (s7_p_p_function(slot_value(global_slot(caaddr(arg)))))) + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(caaddr(arg), s7_p_p_function))) { - set_direct_opt(arg); set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caaddr(arg)))))); return(fx_c_s_opsq_direct); @@ -54302,7 +54596,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf if ((car(arg) == sc->memq_symbol) && (car(cadr(arg)) == sc->car_symbol) && (is_proper_quote(sc, caddr(arg))) && - (is_pair(cadr(caddr(arg))))) + (is_pair(cadaddr(arg)))) { if (s7_list_length(sc, opt2_con(cdr(arg))) == 2) return(fx_memq_car_s_2); @@ -54315,7 +54609,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf (is_proper_quote(sc, caddr(arg)))) { set_opt3_sym(cdr(arg), cadadr(arg)); - set_opt2_con(cdr(arg), cadr(caddr(arg))); + set_opt2_con(cdr(arg), cadaddr(arg)); return((caadr(arg) == sc->car_symbol) ? fx_is_eq_car_q : fx_is_eq_caar_q); } } @@ -54337,24 +54631,58 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf if (c_callee(cadr(arg)) == g_is_eq) { set_opt2_sym(cdr(arg), cadr(cadr(arg))); - set_opt3_any(cdr(arg), (is_pair(caddr(cadr(arg)))) ? cadr(caddr(cadr(arg))) : caddr(cadr(arg))); + set_opt3_any(cdr(arg), (is_pair(caddadr(arg))) ? cadaddr(cadr(arg)) : caddadr(arg)); return(fx_not_is_eq_sq); } return(fx_c_opscq); } return(fx_c_opscq); - + + case HOP_SAFE_C_S_opSCq: + if (is_global_and_has_func(car(arg), s7_p_pp_function)) + { + s7_pointer arg2; + arg2 = caddr(arg); + if ((is_global_and_has_func(car(arg2), s7_p_pi_function)) && + (is_t_integer(caddr(arg2)))) + { + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(slot_value(global_slot(car(arg2)))))); + set_opt3_sym(arg, cadr(arg2)); + set_opt1_con(cdr(arg), caddr(arg2)); + return(fx_c_s_opsiq_direct); + } + if (is_global_and_has_func(car(arg2), s7_p_pp_function)) + { + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg2)))))); + set_opt3_sym(arg, cadr(arg2)); + set_opt1_con(cdr(arg), (is_pair(caddr(arg2))) ? cadr(caddr(arg2)) : caddr(arg2)); + return(fx_c_s_opscq_direct); + } + } + return(fx_c_s_opscq); + case HOP_SAFE_C_opSSq: if (car(arg) == sc->not_symbol) { if (c_callee(cadr(arg)) == g_is_eq) { set_opt2_sym(cdr(arg), cadr(cadr(arg))); - set_opt3_sym(cdr(arg), caddr(cadr(arg))); + set_opt3_sym(cdr(arg), caddadr(arg)); return(fx_not_is_eq_ss); } return(fx_not_opssq); } + if ((is_global_and_has_func(car(arg), s7_p_p_function)) && + (is_global_and_has_func(caadr(arg), s7_p_pp_function))) + { + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(slot_value(global_slot(car(arg)))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caadr(arg)))))); + set_opt3_sym(arg, cadadr(arg)); + set_opt1_sym(cdr(arg), caddadr(arg)); + return(fx_c_opssq_direct); + } return(fx_c_opssq); case HOP_SAFE_C_C_opSSq: @@ -54366,32 +54694,61 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf return(fx_c_c_sqr); } #endif - if (has_direct_opt(arg)) return(direct_c_c_opssq); + if ((is_real(cadr(arg))) && + (is_global_and_has_func(car(arg), s7_p_dd_function)) && + (is_global_and_has_func(caaddr(arg), s7_d_pd_function))) + { + set_opt3_direct(cdr(arg), s7_d_pd_function(slot_value(global_slot(caaddr(arg))))); + set_opt2_direct(cdr(arg), s7_p_dd_function(slot_value(global_slot(car(arg))))); + set_opt3_sym(arg, cadaddr(arg)); + set_opt1_sym(cdr(arg), caddaddr(arg)); + return(fx_c_d_opssq_direct); + } + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(caaddr(arg), s7_p_pp_function))) + { + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(arg)))))); + set_opt3_sym(arg, cadaddr(arg)); + set_opt1_sym(cdr(arg), caddaddr(arg)); + return(fx_c_c_opssq_direct); + } return(fx_c_c_opssq); case HOP_SAFE_C_opSq_opSq: - if (has_direct_opt(arg)) return(direct_c_opsq_opsq); + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(caadr(arg), s7_p_p_function)) && + (is_global_and_has_func(caaddr(arg), s7_p_p_function))) + { + set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(arg)))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caaddr(arg)))))); + return(fx_c_opsq_opsq_direct); + } return(fx_c_opsq_opsq); + + case HOP_SAFE_C_op_S_opSqq: + if (car(arg) == sc->not_symbol) return(fx_not_op_s_opsqq); + return(fx_c_op_s_opsqq); - case HOP_SAFE_C_op_opSq_q: - if ((car(arg) == sc->not_symbol) && /* (not (eq? (car s) 's)) */ + case HOP_SAFE_C_op_opSq_Cq: + if ((car(arg) == sc->not_symbol) && /* (not (eq? (car s) 's)) */ (c_callee(cadr(arg)) == g_is_eq) && (c_callee(cadadr(arg)) == g_car) && (is_symbol(cadr(cadadr(arg)))) && - (is_proper_quote(sc, caddr(cadr(arg))))) + (is_proper_quote(sc, caddadr(arg)))) { set_opt2_sym(cdr(arg), cadr(cadr(cadr(arg)))); - set_opt3_any(cdr(arg), cadr(caddr(cadr(arg)))); + set_opt3_any(cdr(arg), cadaddr(cadr(arg))); return(fx_not_is_eq_car_q); } - return(fx_c_op_opsq_q); + return(fx_c_op_opsq_cq); case HOP_SAFE_C_S_op_S_opSSqq: if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) && (s7_p_pp_function(slot_value(global_slot(caaddr(arg))))) && (s7_p_pp_function(slot_value(global_slot(caaddr(caddr(arg))))))) { - set_direct_opt(arg); set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(arg)))))); set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(caddr(arg))))))); @@ -54399,31 +54756,29 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf } return(fx_c_s_op_s_opssqq); - case HOP_SAFE_C_op_opSSq_q_S: + case HOP_SAFE_C_op_opSSqq_S: if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) && (s7_p_p_function(slot_value(global_slot(caadr(arg))))) && (s7_p_pp_function(slot_value(global_slot(car(cadr(cadr(arg)))))))) { - set_direct_opt(arg); set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(arg)))))); set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caadr(cadr(arg))))))); - return(fx_c_op_opssq_q_s_direct); + return(fx_c_op_opssqq_s_direct); } - return(fx_c_op_opssq_q_s); + return(fx_c_op_opssqq_s); - case HOP_SAFE_C_op_opSq_q_C: - if ((c_callee(arg) == g_string_ref) && (integer(caddr(arg)) == 0) && (c_callee(cadr(arg)) == g_symbol_to_string_uncopied)) + case HOP_SAFE_C_op_opSqq_C: + if ((c_callee(arg) == g_string_ref) && (is_t_integer(caddr(arg))) && (integer(caddr(arg)) == 0) && + (c_callee(cadr(arg)) == g_symbol_to_string_uncopied)) { set_opt3_any(arg, cadadr(arg)); return(fx_string_ref_0_symbol_a); } - return(fx_c_op_opsq_q_c); + return(fx_c_op_opsqq_c); case HOP_SAFE_C_A: if (car(arg) == sc->not_symbol) return(fx_not_a); - if (c_callee(cdr(arg)) == fx_safe_closure_s_d) return(fx_c_closure_s_d); - if (c_callee(cdr(arg)) == fx_safe_closure_s_a) return(fx_c_closure_s_a); return(fx_c_a); case HOP_SAFE_C_AA: @@ -54455,19 +54810,15 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf if ((caadr(body) == sc->is_pair_symbol) && (symbol_id(sc->is_pair_symbol) == 0) && (cadadr(body) == car(closure_args(opt1_lambda(arg))))) - return(fx_and_pair_closure_s); - return(fx_and_2_closure_s); + return(fx_and_pair_closure_s); /* lint arg: (len>1? init), args: (x) body: (and (pair? x) (pair? (cdr x))) */ + return(fx_and_2_closure_s); } - - if (is_h_safe_c_d(body)) - return(fx_safe_closure_s_d); - if (optimize_op(body) == HOP_SAFE_C_opSq_C) { if ((c_callee(body) == g_lint_let_ref) && (cadadr(body) == car(closure_args(opt1_lambda(arg))))) { - set_opt2_sym(cdr(arg), cadr(caddr(body))); + set_opt2_sym(cdr(arg), cadaddr(body)); return(fx_lint_let_ref); /* (var-ref local-var) -> (let-ref (cdr v=local_var) 'ref) */ } } @@ -54476,7 +54827,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf } default: - /* if ((!fx_function[optimize_op(arg)]) && (is_h_optimized(arg))) fprintf(stderr, "fx_choose %s %s\n", op_names[optimize_op(arg)], DISPLAY(arg)); */ + /* if ((!fx_function[optimize_op(arg)]) && (is_h_optimized(arg))) fprintf(stderr, "fx_choose %s %s\n", op_names[optimize_op(arg)], display(arg)); */ return(fx_function[optimize_op(arg)]); } } /* is_optimized */ @@ -54488,16 +54839,18 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf return(NULL); } -#if 0 -#include "fx_tree.h" -#endif - static bool with_c_call(s7_pointer p, s7_function f) { set_c_call(p, f); return(true); } +#define WITH_FX_TREE 0 +#if WITH_FX_TREE +static const char *fx_name(s7_scheme *sc, s7_pointer p); +static bool fx_tu_name(s7_scheme *sc, s7_pointer p); +#endif + static bool fx_tree_out2(s7_scheme *sc, s7_pointer tree, s7_pointer v1, s7_pointer v2, s7_pointer v3, s7_pointer v4) { s7_pointer p; @@ -54507,9 +54860,8 @@ static bool fx_tree_out2(s7_scheme *sc, s7_pointer tree, s7_pointer v1, s7_point if ((c_callee(tree) == fx_c_st) && (cadr(p) != v1) && (cadr(p) != v2) && (cadr(p) != v3) && (cadr(p) != v4)) { - if (s7_p_pp_function(slot_value(global_slot(car(p))))) + if (s7_p_pp_function(slot_value(global_slot(car(p))))) /* dup (vector-ref unique j), envir=out(out(envir)) then lookup "unique" */ { - set_direct_opt(p); set_opt2_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p)))))); return(with_c_call(tree, fx_c_Wt_direct)); } @@ -54521,7 +54873,7 @@ static bool fx_tree_out2(s7_scheme *sc, s7_pointer tree, s7_pointer v1, s7_point static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2) { s7_pointer p; - /* fprintf(stderr, "%s[%d] %s %s %d: %s\n", __func__, __LINE__, DISPLAY(var1), (var2) ? DISPLAY(var2) : "", has_fx(tree), DISPLAY(tree)); */ + /* fprintf(stderr, "%s[%d] %s %s %d: %s\n", __func__, __LINE__, display(var1), (var2) ? display(var2) : "", has_fx(tree), display(tree)); */ p = car(tree); if (is_symbol(p)) { @@ -54544,71 +54896,55 @@ static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_poin if (c_callee(tree) == fx_num_eq_si) return(with_c_call(tree, fx_num_eq_Ti)); #endif } - if (cadr(p) == var2) - { - if (c_callee(tree) == fx_subtract_s1) return(with_c_call(tree, fx_subtract_U1)); - if (c_callee(tree) == fx_add_s1) return(with_c_call(tree, fx_add_U1)); - } - if (is_pair(cddr(p))) + else { - if (caddr(p) == var1) + if (cadr(p) == var2) { -#if (!WITH_GMP) - if (c_callee(tree) == fx_num_eq_ts) return(with_c_call(tree, fx_num_eq_tT)); - if (c_callee(tree) == fx_gt_ts) return(with_c_call(tree, fx_gt_tT)); -#endif + if (c_callee(tree) == fx_subtract_s1) return(with_c_call(tree, fx_subtract_U1)); + if (c_callee(tree) == fx_add_s1) return(with_c_call(tree, fx_add_U1)); } - if (caddr(p) == var2) + else { - if (c_callee(tree) == fx_c_ts) return(with_c_call(tree, fx_c_tU)); + if (is_pair(cddr(p))) + { + if (caddr(p) == var1) + { #if (!WITH_GMP) - if (c_callee(tree) == fx_lt_ts) return(with_c_call(tree, fx_lt_tU)); + if (c_callee(tree) == fx_num_eq_ts) return(with_c_call(tree, fx_num_eq_tT)); + if (c_callee(tree) == fx_gt_ts) return(with_c_call(tree, fx_gt_tT)); + if (c_callee(tree) == fx_geq_ts) return(with_c_call(tree, fx_geq_tT)); #endif - if (c_callee(tree) == fx_cons_ts) return(with_c_call(tree, fx_cons_tU)); - } - } + } + else + { + if (caddr(p) == var2) + { + if (c_callee(tree) == fx_c_ts) return(with_c_call(tree, fx_c_tU)); + if (c_callee(tree) == fx_c_ts_direct) return(with_c_call(tree, fx_c_tU)); +#if (!WITH_GMP) + if (c_callee(tree) == fx_lt_ts) return(with_c_call(tree, fx_lt_tU)); +#endif + }}}}} } return(false); } static s7_b_7p_t s7_b_7p_function(s7_pointer f); -#if 0 -static void tree_globals(s7_scheme *sc, s7_pointer tree, s7_pointer orig) -{ - if (is_normal_symbol(tree)) - { - if (is_global(tree)) fprintf(stderr, "%s in %s\n", DISPLAY(tree), DISPLAY_80(orig)); - } - else - { - if ((is_pair(tree)) && (car(tree) != sc->quote_symbol)) - { - s7_pointer p; - for (p = cdr(tree); is_pair(p); p = cdr(p)) - tree_globals(sc, car(p), orig); - } - } -} -#endif - static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2) /* var2 can be NULL */ { /* extending this to a third variable did not get many hits */ s7_pointer p; - /* fprintf(stderr, "%s[%d] %s %s %s, fx: %d\n", __func__, __LINE__, DISPLAY(tree), DISPLAY(var1), (var2) ? DISPLAY(var2) : "", has_fx(tree)); */ - /* fprintf(stderr, "%s[%d] %s %s %d %s: %s\n", __func__, __LINE__, DISPLAY(var1), (var2) ? DISPLAY(var2) : "", has_fx(tree), fx_name(sc, tree), DISPLAY(tree)); */ + /* fprintf(stderr, "%s[%d] %s %s %s, fx: %d\n", __func__, __LINE__, display(tree), display(var1), (var2) ? display(var2) : "", has_fx(tree)); */ + /* fprintf(stderr, "%s[%d] %s %s %d %s: %s\n", __func__, __LINE__, display(var1), (var2) ? display(var2) : "", has_fx(tree), fx_name(sc, tree), display(tree)); */ #if S7_DEBUGGING - /* tree_globals(sc, tree, tree); */ - if ((!is_symbol(var1)) || ((var2) && (!is_symbol(var2)))) { - fprintf(stderr, "%s %s %s\n", __func__, DISPLAY(var1), (var2) ? DISPLAY(var2) : ""); + fprintf(stderr, "%s %s %s\n", __func__, display(var1), (var2) ? display(var2) : ""); if (sc->stop_at_error) abort(); } #endif - p = car(tree); if (is_symbol(p)) { @@ -54625,8 +54961,9 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if (cadr(p) == var1) { if (c_callee(tree) == fx_c_s) return(with_c_call(tree, fx_c_t)); - if (c_callee(tree) == fx_o_p_p_s) return(with_c_call(tree, fx_o_p_p_t)); + if (c_callee(tree) == fx_c_s_direct) return(with_c_call(tree, fx_c_t_direct)); if (c_callee(tree) == fx_c_ss) return(with_c_call(tree, fx_c_ts)); + if (c_callee(tree) == fx_c_ss_direct) return(with_c_call(tree, fx_c_ts_direct)); if (c_callee(tree) == fx_c_scs) return(with_c_call(tree, fx_c_tcs)); #if (!WITH_GMP) @@ -54634,9 +54971,8 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if ((c_callee(tree) == fx_multiply_ss) && (is_pair(cddr(p))) && (caddr(p) == var2)) return(with_c_call(tree, fx_multiply_tu)); if (c_callee(tree) == fx_add_sf) return(with_c_call(tree, fx_add_tf)); #endif - if (c_callee(tree) == fx_c_sc) + if ((c_callee(tree) == fx_c_sc) || (c_callee(tree) == fx_c_sc_direct)) { - set_c_call(tree, fx_c_tc); if (c_callee(p) == g_char_equal_2) return(with_c_call(tree, fx_char_equal_tc)); #if (!WITH_GMP) if (c_callee(p) == g_less_xf) return(with_c_call(tree, fx_lt_tf)); @@ -54645,16 +54981,14 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if (c_callee(p) == g_geq_xi) return(with_c_call(tree, fx_geq_ti)); if (c_callee(p) == g_leq_xi) return(with_c_call(tree, fx_leq_ti)); if (c_callee(p) == g_greater_xi) return(with_c_call(tree, fx_gt_ti)); - if ((is_global(car(p))) && (s7_p_pp_function(slot_value(global_slot(car(p)))))) +#endif + if (c_callee(tree) == fx_c_sc_direct) { - set_direct_opt(p); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p)))))); if ((opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pp) && (is_t_integer(caddr(p)))) - set_c_call(tree, fx_vector_ref_direct); - else set_c_call(tree, fx_c_tc_direct); + return(with_c_call(tree, fx_vector_ref_direct)); + return(with_c_call(tree, fx_c_tc_direct)); } -#endif - return(true); /* fx_c_tc as default above */ + return(with_c_call(tree, fx_c_tc)); } if (c_callee(tree) == fx_car_s) return(with_c_call(tree, fx_car_t)); @@ -54664,6 +54998,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if (c_callee(tree) == fx_is_null_s) return(with_c_call(tree, fx_is_null_t)); if (c_callee(tree) == fx_is_pair_s) return(with_c_call(tree, fx_is_pair_t)); if (c_callee(tree) == fx_is_symbol_s) return(with_c_call(tree, fx_is_symbol_t)); + if (c_callee(tree) == fx_is_eof_s) return(with_c_call(tree, fx_is_eof_t)); if (c_callee(tree) == fx_is_string_s) return(with_c_call(tree, fx_is_string_t)); if (c_callee(tree) == fx_is_vector_s) return(with_c_call(tree, fx_is_vector_t)); if (c_callee(tree) == fx_is_type_s) return(with_c_call(tree, fx_is_type_t)); @@ -54675,10 +55010,13 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if (c_callee(tree) == fx_subtract_s1) return(with_c_call(tree, fx_subtract_t1)); if (c_callee(tree) == fx_subtract_si) return(with_c_call(tree, fx_subtract_ti)); if (c_callee(tree) == fx_safe_closure_s_a) return(with_c_call(tree, fx_safe_closure_t_a)); - if (c_callee(tree) == fx_safe_closure_s_d) return(with_c_call(tree, fx_safe_closure_t_d)); if (c_callee(tree) == fx_length_s) return(with_c_call(tree, fx_length_t)); - if ((c_callee(tree) == fx_c_s_opsq_direct) && (cadr(caddr(p)) == var2)) return(with_c_call(tree, fx_c_t_opuq_direct)); - if ((c_callee(tree) == fx_c_s_opscq) && (cadr(caddr(p)) == var2)) return(with_c_call(tree, fx_c_t_opucq)); + if ((c_callee(tree) == fx_c_s_opsq_direct) && (cadaddr(p) == var2)) return(with_c_call(tree, fx_c_t_opuq_direct)); + if (c_callee(tree) == fx_c_s_opscq_direct) + { + if (cadaddr(p) == var2) return(with_c_call(tree, fx_c_t_opucq_direct)); + return(with_c_call(tree, fx_c_t_opscq_direct)); + } #if (!WITH_GMP) if (c_callee(tree) == fx_num_eq_ss) { @@ -54694,20 +55032,17 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if (c_callee(tree) == fx_lt_ss) return(with_c_call(tree, fx_lt_tu)); if (c_callee(tree) == fx_leq_ss) return(with_c_call(tree, fx_leq_tu)); if (c_callee(tree) == fx_geq_ss) return(with_c_call(tree, fx_geq_tu)); - if (c_callee(tree) == fx_c_sss) {set_safe_optimize_op(p, OP_SAFE_C_TUS); return(with_c_call(tree, fx_c_tus));} - } - else - { - if (c_callee(tree) == fx_geq_ss) return(with_c_call(tree, fx_geq_ts)); - if (c_callee(tree) == fx_lt_ss) return(with_c_call(tree, fx_lt_ts)); + if ((c_callee(tree) == fx_c_sss) || (c_callee(tree) == fx_c_sss_direct)) {set_safe_optimize_op(p, OP_SAFE_C_TUS); return(with_c_call(tree, fx_c_tus));} } + if (c_callee(tree) == fx_geq_ss) return(with_c_call(tree, fx_geq_ts)); + if (c_callee(tree) == fx_lt_ss) return(with_c_call(tree, fx_lt_ts)); } if (c_callee(tree) == fx_num_eq_si) return(with_c_call(tree, fx_num_eq_ti)); if (c_callee(tree) == fx_gt_ss) return(with_c_call(tree, (is_global(caddr(p))) ? fx_gt_tg : fx_gt_ts)); if (c_callee(tree) == fx_sqr_ss) return(with_c_call(tree, fx_sqr_tt)); #endif if (c_callee(tree) == fx_cons_ss) return(with_c_call(tree, fx_cons_ts)); - if ((c_callee(tree) == fx_c_s_car_s) && (cadr(caddr(p)) == var2)) return(with_c_call(tree, fx_c_t_car_u)); + if ((c_callee(tree) == fx_c_s_car_s) && (cadaddr(p) == var2)) return(with_c_call(tree, fx_c_t_car_u)); if (c_callee(tree) == fx_lint_let_ref) return(with_c_call(tree, fx_lint_let_ref_t)); } else @@ -54716,22 +55051,23 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point { if (c_callee(tree) == fx_c_s) { - if ((is_global(car(p))) && (s7_p_p_function(slot_value(global_slot(car(p)))))) + if (is_global_and_has_func(car(p), s7_p_p_function)) { - set_direct_opt(p); set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(car(p)))))); return(with_c_call(tree, fx_c_u_direct)); } return(with_c_call(tree, fx_c_u)); } - if (c_callee(tree) == fx_o_p_p_s) return(with_c_call(tree, fx_o_p_p_u)); + if (c_callee(tree) == fx_c_s_direct) return(with_c_call(tree, fx_c_u_direct)); if (c_callee(tree) == fx_cdr_s) return(with_c_call(tree, fx_cdr_u)); if (c_callee(tree) == fx_car_s) return(with_c_call(tree, fx_car_u)); if (c_callee(tree) == fx_is_null_s) return(with_c_call(tree, fx_is_null_u)); + if (c_callee(tree) == fx_is_type_s) return(with_c_call(tree, fx_is_type_u)); #if (!WITH_GMP) if (c_callee(tree) == fx_num_eq_ss) return(with_c_call(tree, fx_num_eq_us)); if (c_callee(tree) == fx_num_eq_si) return(with_c_call(tree, fx_num_eq_ui)); - if ((c_callee(tree) == fx_add_s_car_s) && (cadr(caddr(p)) == var1)) return(with_c_call(tree, fx_add_u_car_t)); + if ((c_callee(tree) == fx_add_s_car_s) && (cadaddr(p) == var1)) return(with_c_call(tree, fx_add_u_car_t)); + if (c_callee(tree) == fx_geq_ss) return(with_c_call(tree, fx_geq_us)); #endif if (c_callee(tree) == fx_add_ss) {set_c_call(tree, (caddr(p) == var1) ? fx_add_ut : fx_add_us); return(true);} if (c_callee(tree) == fx_add_s1) return(with_c_call(tree, fx_add_u1)); @@ -54745,23 +55081,23 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point { if (c_callee(tree) == fx_c_opssq) { - if (caddr(cadr(p)) == var1) + if (caddadr(p) == var1) return(with_c_call(tree, fx_c_opstq)); + if ((cadr(cadr(p)) == var1) && (caddadr(p) == var2)) return(with_c_call(tree, fx_c_optuq)); + } + if (c_callee(tree) == fx_c_opssq_direct) + { + if (caddadr(p) == var1) { - if ((is_global(car(p))) && (is_global(caadr(p))) && - (s7_p_p_function(slot_value(global_slot(car(p))))) && - (s7_p_pp_function(slot_value(global_slot(caadr(p)))))) - { - set_direct_opt(p); - set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(car(p)))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caadr(p)))))); - return(with_c_call(tree, fx_c_opstq_direct)); - } - return(with_c_call(tree, fx_c_opstq)); +#if (!WITH_GMP) + if ((opt2_direct(cdr(p)) == (s7_pointer)is_zero_p_p) && (opt3_direct(cdr(p)) == (s7_pointer)remainder_p_pp)) + return(with_c_call(tree, fx_is_zero_remainder_1)); +#endif + return(with_c_call(tree, fx_c_opstq_direct)); /* oputq never happens */ } - if ((cadr(cadr(p)) == var1) && (caddr(cadr(p)) == var2)) return(with_c_call(tree, fx_c_optuq)); } - if ((c_callee(tree) == fx_c_opssq_c) && (caddr(cadr(p)) == var1)) return(with_c_call(tree, fx_c_opstq_c)); - + if ((c_callee(tree) == fx_c_opssq_c) && (caddadr(p) == var1)) return(with_c_call(tree, fx_c_opstq_c)); + if ((c_callee(tree) == fx_vref_vref_ss_s) && (cadadr(p) == var1) && (caddadr(p) == var2)) return(with_c_call(tree, fx_vref_vref_tu_s)); + if (is_pair(cdadr(p))) { if (cadadr(p) == var1) @@ -54770,11 +55106,9 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point { if (c_callee(p) != g_lint_let_ref) /* don't step on opt3_sym */ { - if ((is_global(car(p))) && (is_global(caadr(p))) && - (s7_p_pp_function(slot_value(global_slot(car(p))))) && - (s7_p_p_function(slot_value(global_slot(caadr(p)))))) + if ((is_global_and_has_func(car(p), s7_p_pp_function)) && + (is_global_and_has_func(caadr(p), s7_p_p_function))) { - set_direct_opt(p); if (c_callee(p) == g_memq_2) set_opt3_direct(p, (s7_pointer)memq_2_p_pp); else set_opt3_direct(p, (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p)))))); @@ -54795,20 +55129,18 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if (c_callee(tree) == fx_not_is_pair_s) return(with_c_call(tree, fx_not_is_pair_t)); if (c_callee(tree) == fx_not_is_null_s) return(with_c_call(tree, fx_not_is_null_t)); if (c_callee(tree) == fx_not_is_symbol_s) return(with_c_call(tree, fx_not_is_symbol_t)); - if (c_callee(tree) == fx_is_type_car_s) return(with_c_call(tree, fx_is_type_car_t)); + if (c_callee(tree) == fx_is_type_car_s) + return(with_c_call(tree, (car(p) == sc->is_symbol_symbol) ? fx_is_symbol_car_t : fx_is_type_car_t)); if (c_callee(tree) == fx_c_opsq) { - if ((is_global(car(p))) && (is_global(caadr(p))) && - (s7_p_p_function(slot_value(global_slot(car(p))))) && - (s7_p_p_function(slot_value(global_slot(caadr(p)))))) + if ((is_global_and_has_func(car(p), s7_p_p_function)) && + (is_global_and_has_func(caadr(p), s7_p_p_function))) { - set_direct_opt(p); set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(car(p)))))); set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(p)))))); - set_c_call(tree, fx_c_optq_direct); + return(with_c_call(tree, fx_c_optq_direct)); } - else set_c_call(tree, fx_c_optq); - return(true); + return(with_c_call(tree, fx_c_optq)); } if (c_callee(tree) == fx_is_type_opsq) return(with_c_call(tree, fx_is_type_optq)); if (c_callee(tree) == fx_c_car_s) return(with_c_call(tree, fx_c_car_t)); @@ -54816,14 +55148,35 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if (c_callee(tree) == fx_is_eq_car_q) return(with_c_call(tree, fx_is_eq_car_t_q)); if ((c_callee(tree) == fx_c_opsq_cs) && (cadddr(p) == var2)) {set_c_call(tree, fx_c_optq_cu); return(true);} - if (c_callee(tree) == fx_c_opsq_s) return(with_c_call(tree, fx_c_optq_s)); + if (c_callee(tree) == fx_c_opsq_s) + { + if ((is_global_and_has_func(car(p), s7_p_pp_function)) && + (is_global_and_has_func(caadr(p), s7_p_p_function))) + { + set_opt2_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p)))))); + set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(p)))))); + return(with_c_call(tree, fx_c_optq_s_direct)); + } + return(with_c_call(tree, fx_c_optq_s)); + } + if (c_callee(tree) == fx_c_opsq_s_direct) return(with_c_call(tree, fx_c_optq_s_direct)); + if (c_callee(tree) == fx_and_3) + { + if ((c_callee(cdr(p)) == fx_is_pair_t) && (c_callee(cddr(p)) == fx_is_pair_cdr_t)) + { + if (c_callee(cdddr(p)) == fx_is_null_cddr_t) + return(with_c_call(tree, fx_len2)); + if (c_callee(cdddr(p)) == fx_is_pair_cddr_t) + return(with_c_call(tree, fx_len3)); + } + } } if (cadadr(p) == var2) { if (c_callee(tree) == fx_not_is_null_s) return(with_c_call(tree, fx_not_is_null_u)); #if (!WITH_GMP) - if ((c_callee(tree) == fx_not_opssq) && (caddr(cadr(p)) == var1)) + if ((c_callee(tree) == fx_not_opssq) && (caddadr(p) == var1)) { if (c_callee(cadr(p)) == g_less_2) set_c_call(tree, fx_not_lt_ut); else set_c_call(tree, fx_not_oputq); return(true); @@ -54831,17 +55184,17 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point #endif if ((c_callee(tree) == fx_c_opsq_s) && (caddr(p) == var1)) { - if ((is_global(car(p))) && (is_global(caadr(p))) && - (s7_p_pp_function(slot_value(global_slot(car(p))))) && - (s7_p_p_function(slot_value(global_slot(caadr(p)))))) + if ((is_global_and_has_func(car(p), s7_p_pp_function)) && + (is_global_and_has_func(caadr(p), s7_p_p_function))) /* (memq (car sequence) items) lint */ { - set_direct_opt(p); set_opt2_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p)))))); set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(p)))))); - set_c_call(tree, fx_c_opuq_t_direct); + return(with_c_call(tree, (car(p) == sc->cons_symbol) ? fx_cons_opuq_t : fx_c_opuq_t_direct)); } - else return(with_c_call(tree, fx_c_opuq_t)); + return(with_c_call(tree, fx_c_opuq_t)); } + if ((c_callee(tree) == fx_c_opsq_s_direct) && (caddr(p) == var1)) + return(with_c_call(tree, (car(p) == sc->cons_symbol) ? fx_cons_opuq_t : fx_c_opuq_t_direct)); if (c_callee(tree) == fx_c_car_s) return(with_c_call(tree, fx_c_car_u)); } #if (!WITH_GMP) @@ -54859,9 +55212,8 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point { if (c_callee(tree) == fx_c_cs) { - if ((is_global(car(p))) && (s7_p_pp_function(slot_value(global_slot(car(p)))))) + if (is_global_and_has_func(car(p), s7_p_pp_function)) { - set_direct_opt(p); if (c_callee(p) == g_tree_set_memq_1) set_opt3_direct(cdr(p), (s7_pointer)tree_set_memq_direct); else set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p)))))); @@ -54871,26 +55223,19 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point return(true); } if (c_callee(tree) == fx_c_ss) return(with_c_call(tree, (is_global(cadr(p))) ? fx_c_gt : fx_c_st)); + if (c_callee(tree) == fx_c_ss_direct) {/* fprintf(stderr, "gt/st\n"); */ return(with_c_call(tree, (is_global(cadr(p))) ? fx_c_gt : fx_c_st));} if (c_callee(tree) == fx_hash_table_ref_ss) return(with_c_call(tree, fx_hash_table_ref_st)); - if ((c_callee(tree) == fx_c_opssq_s_direct) && (is_global(cadr(cadr(p))))) - { - if ((opt2_direct(cdr(p)) == (s7_pointer)vector_ref_p_pp) && - (opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pp)) - return(with_c_call(tree, fx_vector_ref_vector_ref_gs_t)); - return(with_c_call(tree, fx_c_opgsq_t_direct)); - } + if ((c_callee(tree) == fx_vref_vref_ss_s) && (is_global(cadr(cadr(p))))) return(with_c_call(tree, fx_vref_vref_gs_t)); } if (is_pair(caddr(p))) { - if ((c_callee(tree) == fx_c_opsq_opssq) && (cadr(caddr(p)) == var1) && (caddr(caddr(p)) == var2)) + if ((c_callee(tree) == fx_c_opsq_opssq) && (cadaddr(p) == var1) && (caddaddr(p) == var2)) { - if ((is_global(car(p))) && (is_global(caadr(p))) && (is_global(caaddr(p))) && - (s7_p_pp_function(slot_value(global_slot(car(p))))) && - (s7_p_p_function(slot_value(global_slot(caadr(p))))) && - (s7_p_pp_function(slot_value(global_slot(caaddr(p)))))) + if ((is_global_and_has_func(car(p), s7_p_pp_function)) && + (is_global_and_has_func(caadr(p), s7_p_p_function)) && + (is_global_and_has_func(caaddr(p), s7_p_pp_function))) { - set_direct_opt(p); set_opt3_direct(p, (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p)))))); set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(p)))))); set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(p)))))); @@ -54914,9 +55259,9 @@ static void fx_tree(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer #if 0 if (is_pair(tree)) fprintf(stderr, "%s[%d]: %s %s %d %s %s\n", func, line, - DISPLAY_80(tree), (is_optimized(tree)) ? op_names[optimize_op(tree)] : "unopt", + display_80(tree), (is_optimized(tree)) ? op_names[optimize_op(tree)] : "unopt", has_fx(tree), /* (has_fx(tree)) ? fx_name(sc, tree) : "", */ - DISPLAY(var1), (var2) ? DISPLAY(var2) : ""); + display(var1), (var2) ? display(var2) : ""); #endif if ((!is_pair(tree)) || ((is_symbol(car(tree))) && @@ -54930,7 +55275,7 @@ static void fx_tree(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer static void fx_tree_outer(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2) { - /* if (is_pair(tree)) fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, DISPLAY_80(tree), has_fx(tree), DISPLAY(var1), (var2) ? DISPLAY(var2) : ""); */ + /* if (is_pair(tree)) fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, display_80(tree), has_fx(tree), display(var1), (var2) ? display(var2) : ""); */ if ((!is_pair(tree)) || ((is_symbol(car(tree))) && (is_definer_or_binder(car(tree))))) @@ -54995,7 +55340,7 @@ static void add_opt_func(s7_pointer f, opt_func_t typ, void *func) #if S7_DEBUGGING else { - fprintf(stderr, "%s[%d]: 'f' is not a c_function\n", __func__, __LINE__); + fprintf(stderr, "%s[%d]: %s is not a c_function\n", __func__, __LINE__, s7_object_to_c_string(cur_sc, f)); if (cur_sc->stop_at_error) abort(); } #endif @@ -55010,9 +55355,6 @@ static void *opt_func(s7_pointer f, opt_func_t typ) if (p->typ == typ) return(p->func); } -#if S7_DEBUGGING - else fprintf(stderr, "%s[%d]: 'f' is not a c_function\n", __func__, __LINE__); -#endif return(NULL); } @@ -55370,10 +55712,8 @@ static bool oo_set_type_4_1(opt_info *p, int slot1, int slot2, int slot3, int sl } #if S7_DEBUGGING -#define alloc_opo(Sc, Expr) alloc_opo_2(Sc, Expr, __func__, __LINE__) static opt_info *alloc_opo_2(s7_scheme *sc, s7_pointer expr, const char *func, int line) #else -#define alloc_opo(Sc, Expr) alloc_opo_1(Sc) static opt_info *alloc_opo_1(s7_scheme *sc) #endif { @@ -55381,7 +55721,7 @@ static opt_info *alloc_opo_1(s7_scheme *sc) if (sc->pc >= OPTS_SIZE) { #if S7_DEBUGGING - fprintf(stderr, "opts overflow: %s (pc: %d)\n", DISPLAY(expr), sc->pc); + fprintf(stderr, "opts overflow: %s (pc: %d)\n", display(expr), sc->pc); #endif longjmp(sc->opt_exit, 1); } @@ -55395,7 +55735,7 @@ static opt_info *alloc_opo_1(s7_scheme *sc) o = sc->opts[sc->pc++]; o->v[O_WRAP].fd = NULL; /* see bool_optimize -- this is a kludge */ #if S7_DEBUGGING - o->vexpr = expr; + o->expr = expr; o->func = func; o->line = line; #endif @@ -55410,7 +55750,7 @@ static opt_info *alloc_opo_1(s7_scheme *sc) static bool return_false(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line) { if (expr) - fprintf(stderr, " %s%s[%d]%s: %s\n", BOLD_TEXT, func, line, UNBOLD_TEXT, DISPLAY_80(expr)); + fprintf(stderr, " %s%s[%d]%s: %s\n", BOLD_TEXT, func, line, UNBOLD_TEXT, display_80(expr)); else fprintf(stderr, " %s%s[%d]%s: false\n", BOLD_TEXT, func, line, UNBOLD_TEXT); return(false); } @@ -55484,55 +55824,19 @@ static s7_pointer opt_types_match(s7_scheme *sc, s7_pointer check, s7_pointer sy return(NULL); } -static s7_double opt_float_any(s7_scheme *sc, s7_pointer expr) -{ - /* caller for s7_float_optimize */ - sc->pc = 0; - return(sc->opts[0]->v[0].fd(sc->opts[0])); -} - -static s7_pointer opt_bool_any(s7_scheme *sc, s7_pointer expr) -{ - /* caller for s7_bool_optimize */ - sc->pc = 0; - return((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F); -} - -static s7_pointer opt_float_any_nr(s7_scheme *sc, s7_pointer expr) -{ - sc->pc = 0; - sc->opts[0]->v[0].fd(sc->opts[0]); - return(NULL); -} - -static s7_pointer opt_int_any_nr(s7_scheme *sc, s7_pointer expr) -{ - sc->pc = 0; - sc->opts[0]->v[0].fi(sc->opts[0]); - return(NULL); -} - -static s7_pointer opt_cell_any_nr(s7_scheme *sc, s7_pointer expr) -{ - sc->pc = 0; - return(sc->opts[0]->v[0].fp(sc->opts[0])); /* faster than returning NULL */ -} - -static s7_pointer opt_bool_any_nr(s7_scheme *sc, s7_pointer expr) -{ - sc->pc = 0; - sc->opts[0]->v[0].fb(sc->opts[0]); - return(NULL); -} - +static s7_double opt_float_any(s7_scheme *sc, s7_pointer expr) {return(sc->opts[0]->v[0].fd(sc->opts[0]));} +static s7_pointer opt_bool_any(s7_scheme *sc, s7_pointer expr) {return((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);} +static s7_pointer opt_float_any_nr(s7_scheme *sc, s7_pointer expr) {sc->opts[0]->v[0].fd(sc->opts[0]); return(NULL);} +static s7_pointer opt_int_any_nr(s7_scheme *sc, s7_pointer expr) {sc->opts[0]->v[0].fi(sc->opts[0]); return(NULL);} +static s7_pointer opt_cell_any_nr(s7_scheme *sc, s7_pointer expr) {return(sc->opts[0]->v[0].fp(sc->opts[0]));} +static s7_pointer opt_bool_any_nr(s7_scheme *sc, s7_pointer expr) {sc->opts[0]->v[0].fb(sc->opts[0]); return(NULL);} /* callers for s7_optimize */ -static s7_pointer opt_wrap_float(s7_scheme *sc, s7_pointer expr) {sc->pc = 0; return(make_real(sc, sc->opts[0]->v[0].fd(sc->opts[0])));} -static s7_pointer opt_wrap_int(s7_scheme *sc, s7_pointer expr) {sc->pc = 0; return(make_integer(sc, sc->opts[0]->v[0].fi(sc->opts[0])));} -static s7_pointer opt_wrap_cell(s7_scheme *sc, s7_pointer expr) {sc->pc = 0; return( sc->opts[0]->v[0].fp(sc->opts[0]));} -static s7_pointer opt_wrap_bool(s7_scheme *sc, s7_pointer expr) {sc->pc = 0; return(( sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);} +static s7_pointer opt_wrap_float(s7_scheme *sc, s7_pointer expr) {return(make_real(sc, sc->opts[0]->v[0].fd(sc->opts[0])));} +static s7_pointer opt_wrap_int(s7_scheme *sc, s7_pointer expr) {return(make_integer(sc, sc->opts[0]->v[0].fi(sc->opts[0])));} +static s7_pointer opt_wrap_cell(s7_scheme *sc, s7_pointer expr) {return(sc->opts[0]->v[0].fp(sc->opts[0]));} +static s7_pointer opt_wrap_bool(s7_scheme *sc, s7_pointer expr) {return((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);} -/* static s7_pointer b_to_p(opt_info *o) {return((o->v[O_WRAP].fb(o)) ? o->sc->T : o->sc->F);} */ static bool p_to_b(opt_info *o) {return(o->v[O_WRAP].fp(o) != o->sc->F);} static s7_pointer d_to_p(opt_info *o) {return(make_real(o->sc, o->v[O_WRAP].fd(o)));} static s7_pointer d_to_p_nr(opt_info *o) {o->v[O_WRAP].fd(o); return(NULL);} @@ -55578,10 +55882,10 @@ static s7_int opt_i_7i_s(opt_info *o) {return(o->v[2].i_7i_f(o->sc, integer(slot static s7_int opt_i_d_c(opt_info *o) {return(o->v[2].i_7d_f(o->sc, o->v[1].x));} static s7_int opt_i_d_s(opt_info *o) {return(o->v[2].i_7d_f(o->sc, real(slot_value(o->v[1].p))));} -static s7_int opt_i_i_f(opt_info *o) {o->sc->pc++; return(o->v[2].i_i_f(o->v[4].fi(o->v[3].o1)));} -static s7_int opt_i_7i_f(opt_info *o) {o->sc->pc++; return(o->v[2].i_7i_f(o->sc, o->v[4].fi(o->v[3].o1)));} -static s7_int opt_i_7d_f(opt_info *o) {o->sc->pc++; return(o->v[2].i_7d_f(o->sc, o->v[4].fd(o->v[3].o1)));} -static s7_int opt_i_7p_f(opt_info *o) {o->sc->pc++; return(o->v[2].i_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));} +static s7_int opt_i_i_f(opt_info *o) {return(o->v[2].i_i_f(o->v[4].fi(o->v[3].o1)));} +static s7_int opt_i_7i_f(opt_info *o) {return(o->v[2].i_7i_f(o->sc, o->v[4].fi(o->v[3].o1)));} +static s7_int opt_i_7d_f(opt_info *o) {return(o->v[2].i_7d_f(o->sc, o->v[4].fd(o->v[3].o1)));} +static s7_int opt_i_7p_f(opt_info *o) {return(o->v[2].i_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));} static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) { @@ -55669,7 +55973,7 @@ static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer static s7_int opt_i_7pi_ss(opt_info *o) {return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} static s7_int ivref_7pi_ss(opt_info *o) {return(int_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_int opt_i_7pi_sf(opt_info *o) {o->sc->pc++; return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} +static s7_int opt_i_7pi_sf(opt_info *o) {return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} static bool i_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) { @@ -55737,23 +56041,21 @@ static s7_int opt_i_ii_sc_sub(opt_info *o) {return(integer(slot_value(o->v[1].p) static s7_int opt_i_ii_ss(opt_info *o) {return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} static s7_int opt_i_ii_ss_add(opt_info *o) {return(integer(slot_value(o->v[1].p)) + integer(slot_value(o->v[2].p)));} static s7_pointer opt_p_ii_ss_add(opt_info *o) {return(make_integer(o->sc, integer(slot_value(o->v[1].p)) + integer(slot_value(o->v[2].p))));} -static s7_int opt_i_ii_cf(opt_info *o) {o->sc->pc++; return(o->v[3].i_ii_f(o->v[1].i, o->v[5].fi(o->v[4].o1)));} -static s7_int opt_i_ii_sf(opt_info *o) {o->sc->pc++; return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o->v[5].fi(o->v[4].o1)));} -static s7_int opt_i_ii_sf_add(opt_info *o) {o->sc->pc++; return(integer(slot_value(o->v[1].p)) + o->v[5].fi(o->v[4].o1));} +static s7_int opt_i_ii_cf(opt_info *o) {return(o->v[3].i_ii_f(o->v[1].i, o->v[5].fi(o->v[4].o1)));} +static s7_int opt_i_ii_sf(opt_info *o) {return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o->v[5].fi(o->v[4].o1)));} +static s7_int opt_i_ii_sf_add(opt_info *o) {return(integer(slot_value(o->v[1].p)) + o->v[5].fi(o->v[4].o1));} static s7_int opt_i_ii_ff(opt_info *o) { s7_int i1, i2; - o->sc->pc++; i1 = o->v[11].fi(o->v[10].o1); - o->sc->pc++; i2 = o->v[9].fi(o->v[8].o1); return(o->v[3].i_ii_f(i1, i2)); } -static s7_int opt_i_ii_fc(opt_info *o) {o->sc->pc++; return(o->v[3].i_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));} -static s7_int opt_i_ii_fc_add(opt_info *o) {o->sc->pc++; return(o->v[11].fi(o->v[10].o1) + o->v[2].i);} -static s7_int opt_i_7ii_fc(opt_info *o) {o->sc->pc++; return(o->v[3].i_7ii_f(o->sc, o->v[11].fi(o->v[10].o1), o->v[2].i));} +static s7_int opt_i_ii_fc(opt_info *o) {return(o->v[3].i_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));} +static s7_int opt_i_ii_fc_add(opt_info *o) {return(o->v[11].fi(o->v[10].o1) + o->v[2].i);} +static s7_int opt_i_7ii_fc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[11].fi(o->v[10].o1), o->v[2].i));} static s7_int opt_i_ii_fco(opt_info *o) {return(o->v[3].i_ii_f(o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))), o->v[5].i));} static s7_int opt_i_ii_fco_add(opt_info *o){return(o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))) + o->v[5].i);} static s7_int opt_i_7ii_fco(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))), o->v[5].i));} @@ -55783,23 +56085,21 @@ static bool i_ii_fc_combinable(s7_scheme *sc, opt_info *opc, s7_i_ii_t func) static s7_int opt_i_7ii_cc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o->v[2].i));} static s7_int opt_i_7ii_cs(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, integer(slot_value(o->v[2].p))));} -static s7_int opt_i_7ii_sc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[2].i));} +static s7_int opt_i_7ii_sc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[2].i));} /* currently unhittable I think */ static s7_int opt_i_7ii_ss(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} -static s7_int opt_i_7ii_cf(opt_info *o) {o->sc->pc++; return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o->v[5].fi(o->v[4].o1)));} -static s7_int opt_i_7ii_sf(opt_info *o) {o->sc->pc++; return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[5].fi(o->v[4].o1)));} +static s7_int opt_i_7ii_cf(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o->v[5].fi(o->v[4].o1)));} +static s7_int opt_i_7ii_sf(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[5].fi(o->v[4].o1)));} static s7_int opt_i_7ii_ff(opt_info *o) { s7_int i1, i2; - o->sc->pc++; i1 = o->v[11].fi(o->v[10].o1); - o->sc->pc++; i2 = o->v[9].fi(o->v[8].o1); return(o->v[3].i_7ii_f(o->sc, i1, i2)); } #if (!WITH_GMP) -static s7_int opt_add_i_random_i(opt_info *o) {return(o->v[1].i + (s7_int)(o->v[2].i * next_random(o->sc->default_rng)));} +static s7_int opt_add_i_random_i(opt_info *o) {return(o->v[1].i + (s7_int)(o->v[2].i * next_random(o->sc->default_rng)));} static s7_int opt_subtract_random_i_i(opt_info *o) {return((s7_int)(o->v[1].i * next_random(o->sc->default_rng)) - o->v[2].i);} #endif @@ -56046,11 +56346,8 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer static s7_int opt_i_iii_fff(opt_info *o) { s7_int i1, i2, i3; - o->sc->pc++; i1 = o->v[11].fi(o->v[10].o1); - o->sc->pc++; i2 = o->v[9].fi(o->v[8].o1); - o->sc->pc++; i3 = o->v[5].fi(o->v[4].o1); return(o->v[3].i_iii_f(i1, i2, i3)); } @@ -56088,7 +56385,6 @@ static bool i_iii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer /* -------- i_7pii -------- */ static s7_int opt_i_7pii_ssf(opt_info *o) { - o->sc->pc++; return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fi(o->v[4].o1))); } @@ -56105,9 +56401,7 @@ static s7_int opt_i_7pii_sss(opt_info *o) static s7_int opt_i_7pii_sff(opt_info *o) { s7_int i1, i2; - o->sc->pc++; i1 = o->v[11].fi(o->v[10].o1); - o->sc->pc++; i2 = o->v[9].fi(o->v[8].o1); return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), i1, i2)); } @@ -56116,7 +56410,6 @@ static s7_int opt_i_7pii_sff(opt_info *o) /* -------- i_7piii -------- */ static s7_int opt_i_7piii_sssf(opt_info *o) { - o->sc->pc++; return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[11].fi(o->v[10].o1))); } @@ -56133,17 +56426,15 @@ static s7_int opt_i_7piii_ssss(opt_info *o) static s7_int opt_i_7piii_sfff(opt_info *o) { s7_int i1, i2, i3; - o->sc->pc++; i1 = o->v[11].fi(o->v[10].o1); - o->sc->pc++; i2 = o->v[9].fi(o->v[8].o1); - o->sc->pc++; - i3 = o->v[5].fi(o->v[4].o1); + i3 = o->v[6].fi(o->v[4].o1); return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), i1, i2, i3)); } static bool opt_i_7piii_args(s7_scheme *sc, opt_info *opc, opt_type_t otype, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp) { + /* opc->v[5] is the called function (int-vector-set! etc) */ s7_pointer slot; slot = opt_integer_symbol(sc, car(indexp2)); if (slot) @@ -56188,7 +56479,7 @@ static bool opt_i_7piii_args(s7_scheme *sc, opt_info *opc, opt_type_t otype, s7_ opc->v[0].fi = opt_i_7piii_sfff; opc->v[11].fi = opc->v[10].o1->v[0].fi; opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[5].fi = opc->v[4].o1->v[0].fi; + opc->v[6].fi = opc->v[4].o1->v[0].fi; /* v[5] is in use */ return(oo_set_type_1(opc, 1, otype)); }}} return(return_false(sc, indexp1, __func__, __LINE__)); @@ -56376,7 +56667,6 @@ static s7_int opt_i_add_any_f(opt_info *o) { opt_info *o1; o1 = o->v[i + 2].o1; - o->sc->pc++; sum += o1->v[0].fi(o1); } return(sum); @@ -56385,66 +56675,48 @@ static s7_int opt_i_add_any_f(opt_info *o) static s7_int opt_i_add2(opt_info *o) { s7_int sum; - o->sc->pc++; sum = o->v[6].fi(o->v[2].o1); - o->sc->pc++; return(sum + o->v[7].fi(o->v[3].o1)); } static s7_int opt_i_mul2(opt_info *o) { s7_int sum; - o->sc->pc++; sum = o->v[6].fi(o->v[2].o1); - o->sc->pc++; return(sum * o->v[7].fi(o->v[3].o1)); } static s7_int opt_i_add3(opt_info *o) { s7_int sum; - o->sc->pc++; sum = o->v[6].fi(o->v[2].o1); - o->sc->pc++; sum += o->v[7].fi(o->v[3].o1); - o->sc->pc++; return(sum + o->v[8].fi(o->v[4].o1)); } static s7_int opt_i_mul3(opt_info *o) { s7_int sum; - o->sc->pc++; sum = o->v[6].fi(o->v[2].o1); - o->sc->pc++; sum *= o->v[7].fi(o->v[3].o1); - o->sc->pc++; return(sum * o->v[8].fi(o->v[4].o1)); } static s7_int opt_i_add4(opt_info *o) { s7_int sum; - o->sc->pc++; sum = o->v[6].fi(o->v[2].o1); - o->sc->pc++; sum += o->v[7].fi(o->v[3].o1); - o->sc->pc++; sum += o->v[8].fi(o->v[4].o1); - o->sc->pc++; return(sum + o->v[9].fi(o->v[5].o1)); } static s7_int opt_i_mul4(opt_info *o) { s7_int sum; - o->sc->pc++; sum = o->v[6].fi(o->v[2].o1); - o->sc->pc++; sum *= o->v[7].fi(o->v[3].o1); - o->sc->pc++; sum *= o->v[8].fi(o->v[4].o1); - o->sc->pc++; return(sum * o->v[9].fi(o->v[5].o1)); } @@ -56456,7 +56728,6 @@ static s7_int opt_i_multiply_any_f(opt_info *o) { opt_info *o1; o1 = o->v[i + 2].o1; - o->sc->pc++; sum *= o1->v[0].fi(o1); } return(sum); @@ -56476,10 +56747,10 @@ static bool i_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x) } if (is_null(p)) { - int32_t i; opc->v[1].i = cur_len; if (cur_len <= 4) { + int32_t i; for (i = 0; i < cur_len; i++) opc->v[i + 6].fi = opc->v[i + 2].o1->v[0].fi; } @@ -56508,7 +56779,6 @@ static bool i_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x) static s7_int opt_set_i_i_f(opt_info *o) { s7_int x; - o->sc->pc++; x = o->v[3].fi(o->v[2].o1); slot_set_value(o->v[1].p, make_integer(o->sc, x)); return(x); @@ -56517,7 +56787,6 @@ static s7_int opt_set_i_i_f(opt_info *o) static s7_int opt_set_i_i_fm(opt_info *o) /* when is this called? */ { s7_int x; - o->sc->pc++; x = o->v[3].fi(o->v[2].o1); integer(slot_value(o->v[1].p)) = x; return(x); @@ -56745,8 +57014,8 @@ static s7_double opt_d_d_c(opt_info *o) {return(o->v[3].d_d_f(o->v[1].x));} static s7_double opt_d_d_s(opt_info *o) {return(o->v[3].d_d_f(real(slot_value(o->v[1].p))));} static s7_double opt_d_7d_c(opt_info *o) {return(o->v[3].d_7d_f(o->sc, o->v[1].x));} static s7_double opt_d_7d_s(opt_info *o) {return(o->v[3].d_7d_f(o->sc, real(slot_value(o->v[1].p))));} -static s7_double opt_d_d_f(opt_info *o) {o->sc->pc++; return(o->v[3].d_d_f(o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_7d_f(opt_info *o) {o->sc->pc++; return(o->v[3].d_7d_f(o->sc, o->v[5].fd(o->v[4].o1)));} +static s7_double opt_d_d_f(opt_info *o) {return(o->v[3].d_d_f(o->v[5].fd(o->v[4].o1)));} +static s7_double opt_d_7d_f(opt_info *o) {return(o->v[3].d_7d_f(o->sc, o->v[5].fd(o->v[4].o1)));} static bool d_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) { @@ -56824,7 +57093,7 @@ static bool d_v_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c /* -------- d_p -------- */ static s7_double opt_d_p_s(opt_info *o) {return(o->v[3].d_p_f(slot_value(o->v[1].p)));} -static s7_double opt_d_p_f(opt_info *o) {o->sc->pc++; return(o->v[3].d_p_f(o->v[5].fp(o->v[4].o1)));} +static s7_double opt_d_p_f(opt_info *o) {return(o->v[3].d_p_f(o->v[5].fp(o->v[4].o1)));} static bool d_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) { @@ -56863,14 +57132,12 @@ static bool d_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c static s7_double opt_d_7pi_sc(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o->v[2].i));} static s7_double opt_d_7pi_ss(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_double opt_d_7pi_sf(opt_info *o) {o->sc->pc++; return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o->v[11].fi(o->v[10].o1)));} +static s7_double opt_d_7pi_sf(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o->v[11].fi(o->v[10].o1)));} static s7_double opt_d_7pi_ff(opt_info *o) { s7_pointer seq; - o->sc->pc++; seq = o->v[5].fp(o->v[4].o1); - o->sc->pc++; return(o->v[3].d_7pi_f(o->sc, seq, o->v[9].fi(o->v[8].o1))); } @@ -56986,7 +57253,7 @@ static bool d_ip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } /* -------- d_pd -------- */ -static s7_double opt_d_pd_sf(opt_info *o) {o->sc->pc++; return(o->v[3].d_pd_f(slot_value(o->v[1].p), o->v[11].fd(o->v[10].o1)));} +static s7_double opt_d_pd_sf(opt_info *o) {return(o->v[3].d_pd_f(slot_value(o->v[1].p), o->v[11].fd(o->v[10].o1)));} static s7_double opt_d_pd_ss(opt_info *o) {return(o->v[3].d_pd_f(slot_value(o->v[1].p), real(slot_value(o->v[2].p))));} static bool d_pd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) @@ -57028,35 +57295,13 @@ static bool d_pd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer /* -------- d_vd -------- */ static s7_double opt_d_vd_c(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[2].x));} static s7_double opt_d_vd_s(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p))));} -static s7_double opt_d_vd_f(opt_info *o) {o->sc->pc++; return(o->v[3].d_vd_f(o->v[5].obj, o->v[9].fd(o->v[8].o1)));} +static s7_double opt_d_vd_f(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[9].fd(o->v[8].o1)));} static s7_double opt_d_vd_o(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj)));} - -static s7_double opt_d_vd_o1_mul(opt_info *o) -{ - opt_info *o1; - o->sc->pc += 2; - o1 = o->sc->opts[o->sc->pc]; - return(o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p)) * o1->v[0].fd(o1))); -} - -static s7_double opt_d_vd_o1(opt_info *o) -{ - opt_info *o1; - o->sc->pc += 2; - o1 = o->sc->opts[o->sc->pc]; - return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_dd_f(real(slot_value(o->v[2].p)), o1->v[0].fd(o1)))); -} - +static s7_double opt_d_vd_o1_mul(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p)) * o->v[11].fd(o->v[10].o1)));} +static s7_double opt_d_vd_o1(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_dd_f(real(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1))));} static s7_double opt_d_vd_o2(opt_info *o) {return(o->v[4].d_vd_f(o->v[6].obj, o->v[5].d_vd_f(o->v[2].obj, real(slot_value(o->v[3].p)))));} static s7_double opt_d_vd_o3(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_dd_f(o->v[6].x, real(slot_value(o->v[2].p)))));} - -static s7_double opt_d_vd_ff(opt_info *o) -{ - opt_info *o1; - o->sc->pc += 2; - o1 = o->sc->opts[o->sc->pc]; - return(o->v[3].d_vd_f(o->v[5].obj, o->v[2].d_vd_f(o->v[4].obj, o1->v[0].fd(o1)))); -} +static s7_double opt_d_vd_ff(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[2].d_vd_f(o->v[4].obj, o->v[11].fd(o->v[10].o1))));} static s7_double opt_d_dd_cs(opt_info *o); static s7_double opt_d_dd_sf_mul(opt_info *o); @@ -57104,6 +57349,8 @@ static bool d_vd_f_combinable(s7_scheme *sc, int32_t start) if (o1->v[0].fd == opt_d_dd_sf_mul) opc->v[0].fd = opt_d_vd_o1_mul; else opc->v[0].fd = opt_d_vd_o1; + opc->v[11].fd = o1->v[5].fd; + opc->v[10].o1 = o1->v[4].o1; return(oo_set_type_2(opc, 1 + (5 << 4), 2, OO_V, OO_D)); } if (o1->v[0].fd == opt_d_vd_f) @@ -57112,12 +57359,13 @@ static bool d_vd_f_combinable(s7_scheme *sc, int32_t start) opc->v[4].obj = o1->v[5].obj; opc->v[6].p = o1->v[1].p; opc->v[0].fd = opt_d_vd_ff; + opc->v[11].fd = o1->v[9].fd; + opc->v[10].o1 = o1->v[8].o1; return(oo_set_type_2(opc, 1 + (5 << 4), 6 + ((4 << 4)), OO_V, OO_V)); } return(return_false(sc, NULL, __func__, __LINE__)); } - static bool d_vd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) { if (is_symbol(cadr(car_x))) @@ -57190,7 +57438,7 @@ static bool d_vd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } /* -------- d_id -------- */ -static s7_double opt_d_id_sf(opt_info *o) {o->sc->pc++; return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));} +static s7_double opt_d_id_sf(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));} static s7_double opt_d_id_sc(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[2].x));} static s7_double opt_d_id_sfo1(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].d_v_f(o->v[2].obj)));} static s7_double opt_d_id_sfo(opt_info *o) {return(o->v[4].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].d_vd_f(o->v[6].obj, real(slot_value(o->v[3].p)))));} @@ -57271,30 +57519,25 @@ static s7_double opt_d_dd_ss(opt_info *o) {return(o->v[3].d_dd_f(real(slot_v static s7_double opt_d_dd_ss_add(opt_info *o) {return(real(slot_value(o->v[1].p)) + real(slot_value(o->v[2].p)));} static s7_double opt_d_dd_ss_mul(opt_info *o) {return(real(slot_value(o->v[1].p)) * real(slot_value(o->v[2].p)));} -static s7_double opt_d_dd_cf(opt_info *o) {o->sc->pc++; return(o->v[3].d_dd_f(o->v[1].x, o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_dd_fc(opt_info *o) {o->sc->pc++; return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), o->v[2].x));} +static s7_double opt_d_dd_cf(opt_info *o) {return(o->v[3].d_dd_f(o->v[1].x, o->v[5].fd(o->v[4].o1)));} +static s7_double opt_d_dd_fc(opt_info *o) {return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), o->v[2].x));} #if (!WITH_GMP) static s7_double opt_subtract_random_f_f(opt_info *o) {return(o->v[1].x * next_random(o->sc->default_rng) - o->v[2].x);} #endif -static s7_double opt_d_dd_fc_add(opt_info *o) {o->sc->pc++; return(o->v[5].fd(o->v[4].o1) + o->v[2].x);} -static s7_double opt_d_dd_fc_subtract(opt_info *o) {o->sc->pc++; return(o->v[5].fd(o->v[4].o1) - o->v[2].x);} -static s7_double opt_d_dd_sf(opt_info *o) {o->sc->pc++; return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_dd_sf_mul(opt_info *o) {o->sc->pc++; return(real(slot_value(o->v[1].p)) * o->v[5].fd(o->v[4].o1));} +static s7_double opt_d_dd_fc_add(opt_info *o) {return(o->v[5].fd(o->v[4].o1) + o->v[2].x);} +static s7_double opt_d_dd_fc_subtract(opt_info *o) {return(o->v[5].fd(o->v[4].o1) - o->v[2].x);} +static s7_double opt_d_dd_sf(opt_info *o) {return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));} +static s7_double opt_d_dd_sf_mul(opt_info *o) {return(real(slot_value(o->v[1].p)) * o->v[5].fd(o->v[4].o1));} static s7_double opt_d_7dd_cc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o->v[2].x));} static s7_double opt_d_7dd_cs(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[2].x, real(slot_value(o->v[1].p))));} static s7_double opt_d_7dd_sc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[2].x));} static s7_double opt_d_7dd_ss(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p))));} -static s7_double opt_d_7dd_cf(opt_info *o) {o->sc->pc++; return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_7dd_fc(opt_info *o) {o->sc->pc++; return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), o->v[2].x));} - -static s7_double opt_d_7dd_sf(opt_info *o) -{ - o->sc->pc++; - return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1))); -} +static s7_double opt_d_7dd_cf(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o->v[5].fd(o->v[4].o1)));} +static s7_double opt_d_7dd_fc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), o->v[2].x));} +static s7_double opt_d_7dd_sf(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));} static s7_double opt_d_dd_sfo(opt_info *o) { @@ -57335,9 +57578,9 @@ static bool d_dd_sf_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func) return(return_false(sc, NULL, __func__, __LINE__)); } -static s7_double opt_d_dd_fs(opt_info *o) {o->sc->pc++; return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));} -static s7_double opt_d_dd_fs_mul(opt_info *o) {o->sc->pc++; return(o->v[5].fd(o->v[4].o1) * real(slot_value(o->v[1].p)));} -static s7_double opt_d_7dd_fs(opt_info *o) {o->sc->pc++; return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));} +static s7_double opt_d_dd_fs(opt_info *o) {return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));} +static s7_double opt_d_dd_fs_mul(opt_info *o) {return(o->v[5].fd(o->v[4].o1) * real(slot_value(o->v[1].p)));} +static s7_double opt_d_7dd_fs(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));} static s7_double opt_d_dd_fso(opt_info *o) { @@ -57381,82 +57624,63 @@ static bool d_dd_fs_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func) static s7_double opt_d_dd_ff(opt_info *o) { s7_double x1; - o->sc->pc++; x1 = o->v[9].fd(o->v[8].o1); - o->sc->pc++; return(o->v[3].d_dd_f(x1, o->v[11].fd(o->v[10].o1))); } static s7_double opt_d_dd_ff_mul(opt_info *o) { s7_double x1; - o->sc->pc++; x1 = o->v[9].fd(o->v[8].o1); - o->sc->pc++; return(x1 * o->v[11].fd(o->v[10].o1)); } static s7_double opt_d_dd_ff_add(opt_info *o) { s7_double x1; - o->sc->pc++; x1 = o->v[5].fd(o->v[4].o1); - o->sc->pc++; return(x1 + o->v[11].fd(o->v[10].o1)); } static s7_double opt_d_dd_ff_add_mul(opt_info *o) { s7_double x1, x2; - o->sc->pc++; x1 = o->v[5].fd(o->v[4].o1); - o->sc->pc += 2; x2 = o->v[9].fd(o->v[8].o1); - o->sc->pc++; return(x1 + (x2 * o->v[11].fd(o->v[10].o1))); } static s7_double opt_d_dd_ff_add_fv_ref(opt_info *o) { s7_double x1; - o->sc->pc++; x1 = o->v[5].fd(o->v[4].o1); - o->sc->pc += 2; return(x1 + float_vector_ref_d_7pi(o->sc, slot_value(o->v[6].p), o->v[9].fi(o->v[8].o1))); } static s7_double opt_d_dd_ff_sub(opt_info *o) { s7_double x1; - o->sc->pc++; x1 = o->v[5].fd(o->v[4].o1); - o->sc->pc++; return(x1 - o->v[11].fd(o->v[10].o1)); } static s7_double opt_d_7dd_ff(opt_info *o) { s7_double x1; - o->sc->pc++; x1 = o->v[9].fd(o->v[8].o1); - o->sc->pc++; return(o->v[3].d_7dd_f(o->sc, x1, o->v[11].fd(o->v[10].o1))); } static s7_double opt_d_dd_ff_o1(opt_info *o) { - opt_info *o2; s7_double x1; x1 = o->v[2].d_v_f(o->v[1].obj); - o2 = o->sc->opts[o->sc->pc += 2]; - return(o->v[3].d_dd_f(x1, o2->v[0].fd(o2))); + return(o->v[3].d_dd_f(x1, o->v[11].fd(o->v[10].o1))); } static s7_double opt_d_dd_ff_mul1(opt_info *o) { - opt_info *o2; - o2 = o->sc->opts[o->sc->pc += 2]; - return(o->v[2].d_v_f(o->v[1].obj) * o2->v[0].fd(o2)); + return(o->v[2].d_v_f(o->v[1].obj) * o->v[11].fd(o->v[10].o1)); } static s7_double opt_d_dd_ff_o2(opt_info *o) @@ -57481,9 +57705,7 @@ static s7_double opt_d_dd_ff_o3(opt_info *o) static s7_double opt_d_dd_fff(opt_info *o) { s7_double x1, x2; - o->sc->pc++; x1 = o->v[3+4].d_dd_f(o->v[3+5].d_7pi_f(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))), real(slot_value(o->v[3+1].p))); /* dd_fso */ - o->sc->pc++; x2 = o->v[8+4].d_dd_f(o->v[8+5].d_7pi_f(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))), real(slot_value(o->v[8+1].p))); /* dd_fso */ return(o->v[3].d_dd_f(x1, x2)); } @@ -57491,9 +57713,7 @@ static s7_double opt_d_dd_fff(opt_info *o) static s7_double opt_d_mm_fff(opt_info *o) { s7_double x1, x2; - o->sc->pc++; x1 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))) * real(slot_value(o->v[3+1].p)); - o->sc->pc++; x2 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))) * real(slot_value(o->v[8+1].p)); return(o->v[3].d_dd_f(x1, x2)); } @@ -57501,9 +57721,7 @@ static s7_double opt_d_mm_fff(opt_info *o) static s7_double opt_d_dd_fff_rev(opt_info *o) /* faster with o->sc? */ { s7_double x1, x2; - o->sc->pc++; x1 = o->v[3+4].d_dd_f(real(slot_value(o->v[3+1].p)), o->v[3+5].d_7pi_f(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p)))); - o->sc->pc++; x2 = o->v[8+4].d_dd_f(real(slot_value(o->v[8+1].p)), o->v[8+5].d_7pi_f(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p)))); return(o->v[3].d_dd_f(x1, x2)); } @@ -57900,16 +58118,13 @@ static s7_double opt_d_ddd_sss(opt_info *o) static s7_double opt_d_ddd_ssf(opt_info *o) { - o->sc->pc++; return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1))); } static s7_double opt_d_ddd_sff(opt_info *o) { s7_double x1, x2; - o->sc->pc++; x1 = o->v[11].fd(o->v[10].o1); - o->sc->pc++; x2 = o->v[9].fd(o->v[8].o1); return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), x1, x2)); } @@ -57917,11 +58132,8 @@ static s7_double opt_d_ddd_sff(opt_info *o) static s7_double opt_d_ddd_fff(opt_info *o) { s7_double x1, x2, x3; - o->sc->pc++; x1 = o->v[11].fd(o->v[10].o1); - o->sc->pc++; x2 = o->v[9].fd(o->v[8].o1); - o->sc->pc++; x3 = o->v[6].fd(o->v[5].o1); return(o->v[4].d_ddd_f(x1, x2, x3)); } @@ -57939,9 +58151,7 @@ static s7_double opt_d_ddd_fff2(opt_info *o) { s7_double x1, x2, x3; x1 = o->v[1].d_v_f(o->v[2].obj); - o->sc->pc += 2; x2 = o->v[9].fd(o->v[12].o1); - o->sc->pc++; x3 = o->v[6].fd(o->v[5].o1); return(o->v[7].d_ddd_f(x1, x2, x3)); } @@ -58056,13 +58266,11 @@ static bool d_ddd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer /* -------- d_7pid -------- */ static s7_double opt_d_7pid_ssf(opt_info *o) { - o->sc->pc++; return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1))); } static s7_pointer opt_d_7pid_ssf_nr(opt_info *o) { - o->sc->pc++; o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1)); return(NULL); } @@ -58080,9 +58288,7 @@ static s7_double opt_d_7pid_ssc(opt_info *o) static s7_double opt_d_7pid_sff(opt_info *o) { s7_int pos; - o->sc->pc++; pos = o->v[11].fi(o->v[10].o1); - o->sc->pc++; return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), pos, o->v[9].fd(o->v[8].o1))); } @@ -58196,7 +58402,6 @@ static bool d_7pid_ssf_combinable(s7_scheme *sc, opt_info *opc) /* -------- d_7piid -------- */ static s7_double opt_d_7piid_sssf(opt_info *o) { - o->sc->pc++; return(o->v[5].d_7piid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[9].fd(o->v[8].o1))); } @@ -58207,25 +58412,21 @@ static s7_double opt_d_7piid_sssc(opt_info *o) static s7_double opt_d_7piid_scsf(opt_info *o) { - o->sc->pc++; return(o->v[5].d_7piid_f(o->sc, slot_value(o->v[1].p), o->v[2].i, integer(slot_value(o->v[3].p)), o->v[11].fd(o->v[10].o1))); } static s7_double opt_d_7piid_sfff(opt_info *o) { s7_int i1, i2; - o->sc->pc++; i1 = o->v[11].fi(o->v[10].o1); - o->sc->pc++; i2 = o->v[9].fi(o->v[8].o1); - o->sc->pc++; return(o->v[5].d_7piid_f(o->sc, slot_value(o->v[1].p), i1, i2, o->v[4].fd(o->v[3].o1))); } static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp) { s7_pointer settee; - /* fprintf(stderr, "%s: %s %s %s %s\n", __func__, DISPLAY(v), DISPLAY(indexp1), (indexp2) ? DISPLAY(indexp1) : "null", DISPLAY(valp)); */ + /* fprintf(stderr, "%s: %s %s %s %s\n", __func__, display(v), display(indexp1), (indexp2) ? display(indexp1) : "null", display(valp)); */ settee = symbol_to_slot(sc, v); if ((is_slot(settee)) && (!is_immutable(slot_value(settee)))) @@ -58354,9 +58555,7 @@ static s7_double opt_d_7pii_scs(opt_info *o) static s7_double opt_d_7pii_sff(opt_info *o) { s7_int i1, i2; - o->sc->pc++; i1 = o->v[11].fi(o->v[10].o1); - o->sc->pc++; i2 = o->v[9].fi(o->v[8].o1); return(o->v[4].d_7pii_f(o->sc, slot_value(o->v[1].p), i1, i2)); } @@ -58494,22 +58693,16 @@ static bool d_7piid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point } /* -------- d_vid -------- */ -static s7_double opt_d_vid_ssf(opt_info *o) -{ - o->sc->pc++; - return(o->v[4].d_vid_f(o->v[5].obj, integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1))); -} +static s7_double opt_d_vid_ssf(opt_info *o) {return(o->v[4].d_vid_f(o->v[5].obj, integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1)));} static inline s7_double opt_fmv(opt_info *o) { /* d_vid_ssf -> d_dd_ff_o1 -> d_vd_o1 -> d_dd_ff_o3, this is a placeholder */ opt_info *o1, *o2, *o3; s7_double amp_env, index_env, vib; - s7_scheme *sc; - sc = o->sc; - o1 = sc->opts[sc->pc + 1]; - o2 = sc->opts[sc->pc + 3]; - o3 = sc->opts[sc->pc += 5]; + o1 = o->v[12].o1; /* o2 below */ + o2 = o->v[13].o1; /* o3 below */ + o3 = o->v[14].o1; /* o1 below */ amp_env = o1->v[2].d_v_f(o1->v[1].obj); vib = real(slot_value(o2->v[2].p)); index_env = o3->v[5].d_v_f(o3->v[1].obj); @@ -58563,7 +58756,12 @@ static bool d_vid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if ((o1->v[0].fd == opt_d_dd_ff_o3) && (o1->v[4].d_dd_f == multiply_d_dd) && (o3->v[4].d_dd_f == add_d_dd)) - opc->v[0].fd = opt_fmv; /* a placeholder -- see below */ + { + opc->v[0].fd = opt_fmv; /* a placeholder -- see below */ + opc->v[12].o1 = o2; + opc->v[13].o1 = o3; + opc->v[14].o1 = o1; + } } } return(oo_set_type_2(opc, 1 + (5 << 4), 2, OO_V, OO_I)); @@ -58578,9 +58776,7 @@ static bool d_vid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer static s7_double opt_d_vdd_ff(opt_info *o) { s7_double x1, x2; - o->sc->pc++; x1 = o->v[11].fd(o->v[10].o1); - o->sc->pc++; x2 = o->v[9].fd(o->v[8].o1); return(o->v[4].d_vdd_f(o->v[5].obj, x1, x2)); } @@ -58626,13 +58822,9 @@ static bool d_vdd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer static s7_double opt_d_dddd_ffff(opt_info *o) { s7_double x1, x2, x3, x4; - o->sc->pc++; x1 = o->v[11].fd(o->v[10].o1); - o->sc->pc++; x2 = o->v[9].fd(o->v[8].o1); - o->sc->pc++; x3 = o->v[5].fd(o->v[4].o1); - o->sc->pc++; x4 = o->v[3].fd(o->v[2].o1); return(o->v[1].d_dddd_f(x1, x2, x3, x4)); } @@ -58675,7 +58867,6 @@ static s7_double opt_d_add_any_f(opt_info *o) { opt_info *o1; o1 = o->v[i + 2].o1; - o->sc->pc++; sum += o1->v[0].fd(o1); } return(sum); @@ -58689,7 +58880,6 @@ static s7_double opt_d_multiply_any_f(opt_info *o) { opt_info *o1; o1 = o->v[i + 2].o1; - o->sc->pc++; sum *= o1->v[0].fd(o1); } return(sum); @@ -58730,7 +58920,6 @@ static bool d_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x, int32_t static s7_double opt_set_d_d_f(opt_info *o) { s7_double x; - o->sc->pc++; x = o->v[3].fd(o->v[2].o1); slot_set_value(o->v[1].p, make_real(o->sc, x)); return(x); @@ -58739,7 +58928,6 @@ static s7_double opt_set_d_d_f(opt_info *o) static s7_double opt_set_d_d_fm(opt_info *o) { s7_double x; - o->sc->pc++; x = o->v[3].fd(o->v[2].o1); real(slot_value(o->v[1].p)) = x; return(x); @@ -58898,26 +59086,18 @@ static bool d_implicit_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) /* -------------------------------- bool opts -------------------------------- */ -static bool opt_b_t(opt_info *o) {return(true);} -static bool opt_b_f(opt_info *o) {return(false);} static bool opt_b_s(opt_info *o) {return(slot_value(o->v[1].p) != o->sc->F);} static bool opt_bool_not_pair(s7_scheme *sc, s7_pointer car_x) { - opt_info *opc; s7_pointer p; if (!is_symbol(car_x)) - { - if (!s7_is_boolean(car_x)) - return(return_false(sc, car_x, __func__, __LINE__)); /* i.e. use cell_optimize */ - opc = alloc_opo(sc, car_x); - opc->v[0].fb = ((car_x == sc->F) ? opt_b_f : opt_b_t); - return(oo_set_type_0(opc)); - } + return(return_false(sc, car_x, __func__, __LINE__)); /* i.e. use cell_optimize */ p = opt_simple_symbol(sc, car_x); if ((p) && (s7_is_boolean(slot_value(p)))) { + opt_info *opc; opc = alloc_opo(sc, car_x); opc->v[1].p = p; opc->v[0].fb = opt_b_s; @@ -58928,13 +59108,13 @@ static bool opt_bool_not_pair(s7_scheme *sc, s7_pointer car_x) /* -------- b_idp -------- */ static bool opt_b_i_s(opt_info *o) {return(o->v[2].b_i_f(integer(slot_value(o->v[1].p))));} -static bool opt_b_i_f(opt_info *o) {o->sc->pc++; return(o->v[2].b_i_f(o->v[11].fi(o->v[10].o1)));} +static bool opt_b_i_f(opt_info *o) {return(o->v[2].b_i_f(o->v[11].fi(o->v[10].o1)));} static bool opt_b_d_s(opt_info *o) {return(o->v[2].b_d_f(real(slot_value(o->v[1].p))));} -static bool opt_b_d_f(opt_info *o) {o->sc->pc++; return(o->v[2].b_d_f(o->v[11].fd(o->v[10].o1)));} +static bool opt_b_d_f(opt_info *o) {return(o->v[2].b_d_f(o->v[11].fd(o->v[10].o1)));} static bool opt_b_p_s(opt_info *o) {return(o->v[2].b_p_f(slot_value(o->v[1].p)));} -static bool opt_b_p_f(opt_info *o) {o->sc->pc++; return(o->v[2].b_p_f(o->v[4].fp(o->v[3].o1)));} +static bool opt_b_p_f(opt_info *o) {return(o->v[2].b_p_f(o->v[4].fp(o->v[3].o1)));} static bool opt_b_7p_s(opt_info *o) {return(o->v[2].b_7p_f(o->sc, slot_value(o->v[1].p)));} -static bool opt_b_7p_f(opt_info *o) {o->sc->pc++; return(o->v[2].b_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));} +static bool opt_b_7p_f(opt_info *o) {return(o->v[2].b_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));} #if (!WITH_GMP) static bool opt_zero_mod(opt_info *o) @@ -59136,28 +59316,24 @@ static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp) static bool opt_b_pp_ff(opt_info *o) { s7_pointer p1; - o->sc->pc++; p1 = o->v[9].fp(o->v[8].o1); - o->sc->pc++; return(o->v[3].b_pp_f(p1, o->v[11].fp(o->v[10].o1))); } static bool opt_b_7pp_ff(opt_info *o) { s7_pointer p1; - o->sc->pc++; p1 = o->v[9].fp(o->v[8].o1); - o->sc->pc++; return(o->v[3].b_7pp_f(o->sc, p1, o->v[11].fp(o->v[10].o1))); } -static bool opt_b_pp_sf(opt_info *o) {o->sc->pc++; return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));} -static bool opt_b_pp_fs(opt_info *o) {o->sc->pc++; return(o->v[3].b_pp_f(o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));} +static bool opt_b_pp_sf(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));} +static bool opt_b_pp_fs(opt_info *o) {return(o->v[3].b_pp_f(o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));} static bool opt_b_pp_ss(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), slot_value(o->v[2].p)));} static bool opt_b_pp_sc(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[2].p));} static bool opt_b_pp_sfo(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));} -static bool opt_b_7pp_sf(opt_info *o) {o->sc->pc++; return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));} -static bool opt_b_7pp_fs(opt_info *o) {o->sc->pc++; return(o->v[3].b_7pp_f(o->sc, o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));} +static bool opt_b_7pp_sf(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));} +static bool opt_b_7pp_fs(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));} static bool opt_b_7pp_ss(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} static bool opt_lt_b_7pp_ss(opt_info *o) {return(lt_b_7pp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} static bool opt_b_7pp_sc(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[2].p));} @@ -59319,11 +59495,7 @@ static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } /* -------- b_pi -------- */ -static bool opt_b_pi_fs(opt_info *o) -{ - o->sc->pc++; - return(o->v[2].b_pi_f(o->sc, o->v[11].fp(o->v[10].o1), integer(slot_value(o->v[1].p)))); -} +static bool opt_b_pi_fs(opt_info *o) {return(o->v[2].b_pi_f(o->sc, o->v[11].fp(o->v[10].o1), integer(slot_value(o->v[1].p))));} static bool b_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg2) { @@ -59355,16 +59527,14 @@ static bool opt_b_dd_sc_lt(opt_info *o) {return(real(slot_value(o->v[1].p)) < o- static bool opt_b_dd_sc_geq(opt_info *o) {return(real(slot_value(o->v[1].p)) >= o->v[2].x);} static bool opt_b_dd_sc_eq(opt_info *o) {return(real(slot_value(o->v[1].p)) == o->v[2].x);} -static bool opt_b_dd_sf(opt_info *o) {o->sc->pc++; return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), o->v[11].fd(o->v[10].o1)));} -static bool opt_b_dd_fs(opt_info *o) {o->sc->pc++; return(o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), real(slot_value(o->v[1].p))));} -static bool opt_b_dd_fc(opt_info *o) {o->sc->pc++; return(o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), o->v[1].x));} +static bool opt_b_dd_sf(opt_info *o) {return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), o->v[11].fd(o->v[10].o1)));} +static bool opt_b_dd_fs(opt_info *o) {return(o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), real(slot_value(o->v[1].p))));} +static bool opt_b_dd_fc(opt_info *o) {return(o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), o->v[1].x));} static bool opt_b_dd_ff(opt_info *o) { s7_double x1, x2; - o->sc->pc++; x1 = o->v[11].fd(o->v[10].o1); - o->sc->pc++; x2 = o->v[9].fd(o->v[8].o1); return(o->v[3].b_dd_f(x1, x2)); } @@ -59433,30 +59603,40 @@ static bool b_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer /* -------- b_ii -------- */ -static bool opt_b_ii_ss(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} -static bool opt_b_ii_ss_lt(opt_info *o) {return(integer(slot_value(o->v[1].p)) < integer(slot_value(o->v[2].p)));} -static bool opt_b_ii_ss_gt(opt_info *o) {return(integer(slot_value(o->v[1].p)) > integer(slot_value(o->v[2].p)));} +static bool opt_b_ii_ss(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} +static bool opt_b_ii_ss_lt(opt_info *o) {return(integer(slot_value(o->v[1].p)) < integer(slot_value(o->v[2].p)));} +static bool opt_b_ii_ss_gt(opt_info *o) {return(integer(slot_value(o->v[1].p)) > integer(slot_value(o->v[2].p)));} static bool opt_b_ii_ss_leq(opt_info *o) {return(integer(slot_value(o->v[1].p)) <= integer(slot_value(o->v[2].p)));} static bool opt_b_ii_ss_geq(opt_info *o) {return(integer(slot_value(o->v[1].p)) >= integer(slot_value(o->v[2].p)));} -static bool opt_b_ii_ss_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == integer(slot_value(o->v[2].p)));} -static bool opt_b_ii_sc(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i));} -static bool opt_b_ii_sc_lt(opt_info *o) {return(integer(slot_value(o->v[1].p)) < o->v[2].i);} +static bool opt_b_ii_ss_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == integer(slot_value(o->v[2].p)));} +static bool opt_b_ii_sc(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i));} +static bool opt_b_ii_sc_lt(opt_info *o) {return(integer(slot_value(o->v[1].p)) < o->v[2].i);} +static bool opt_b_ii_sc_leq(opt_info *o) {return(integer(slot_value(o->v[1].p)) <= o->v[2].i);} +static bool opt_b_ii_sc_gt(opt_info *o) {return(integer(slot_value(o->v[1].p)) > o->v[2].i);} static bool opt_b_ii_sc_geq(opt_info *o) {return(integer(slot_value(o->v[1].p)) >= o->v[2].i);} -static bool opt_b_ii_sc_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == o->v[2].i);} +static bool opt_b_ii_sc_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == o->v[2].i);} +static bool opt_b_ii_sc_bit(opt_info *o) {return((integer(slot_value(o->v[1].p)) & ((int64_t)(1LL << o->v[2].i))) != 0);} + +/* + * fx_c_opssq_s_direct and s_opssq_direct and opssq_opssq (2) with vref inner? + * opssq_opssq direct + * (* (- ) (- ) in b, (+|- (* ) (* )) in big, (< (- ) (- )) q + * fx_c_s_op_opssq_opssqq + */ static bool opt_b_ii_ff(opt_info *o) { s7_int i1, i2; - o->sc->pc++; i1 = o->v[11].fi(o->v[10].o1); - o->sc->pc++; i2 = o->v[9].fi(o->v[8].o1); return(o->v[3].b_ii_f(i1, i2)); } -static bool opt_b_ii_fs(opt_info *o) {o->sc->pc++; return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));} -static bool opt_b_ii_fc(opt_info *o) {o->sc->pc++; return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));} -static bool opt_b_ii_sf(opt_info *o) {o->sc->pc++; return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[11].fi(o->v[10].o1)));} +static bool opt_b_ii_fs(opt_info *o) {return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));} +static bool opt_b_ii_sf(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[11].fi(o->v[10].o1)));} +static bool opt_b_ii_sf_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == o->v[11].fi(o->v[10].o1));} +static bool opt_b_ii_fc(opt_info *o) {return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));} +static bool opt_b_ii_fc_eq(opt_info *o) {return(o->v[11].fi(o->v[10].o1) == o->v[2].i);} static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg1, s7_pointer arg2) { @@ -59471,41 +59651,31 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (is_symbol(arg2)) { opc->v[2].p = symbol_to_slot(sc, arg2); - opc->v[0].fb = opt_b_ii_ss; - if (bif == lt_b_ii) - opc->v[0].fb = opt_b_ii_ss_lt; - else - { - if (bif == gt_b_ii) - opc->v[0].fb = opt_b_ii_ss_gt; - else - { - if (bif == geq_b_ii) - opc->v[0].fb = opt_b_ii_ss_geq; - else - { - if (bif == leq_b_ii) - opc->v[0].fb = opt_b_ii_ss_leq; - else - { - if (bif == num_eq_b_ii) - opc->v[0].fb = opt_b_ii_ss_eq; - } - } - } - } + + opc->v[0].fb = (bif == lt_b_ii) ? opt_b_ii_ss_lt : + ((bif == leq_b_ii) ? opt_b_ii_ss_leq : + ((bif == gt_b_ii) ? opt_b_ii_ss_gt : + ((bif == geq_b_ii) ? opt_b_ii_ss_geq : + ((bif == num_eq_b_ii) ? opt_b_ii_ss_eq : + opt_b_ii_ss)))); return(oo_set_type_2(opc, 1, 2, OO_I, OO_I)); } if (is_opt_int(arg2)) { opc->v[2].i = integer(arg2); - opc->v[0].fb = (bif == lt_b_ii) ? opt_b_ii_sc_lt : ((bif == geq_b_ii) ? opt_b_ii_sc_geq : ((bif == num_eq_b_ii) ? opt_b_ii_sc_eq : opt_b_ii_sc)); + opc->v[0].fb = (bif == lt_b_ii) ? opt_b_ii_sc_lt : + ((bif == leq_b_ii) ? opt_b_ii_sc_leq : + ((bif == gt_b_ii) ? opt_b_ii_sc_gt : + ((bif == geq_b_ii) ? opt_b_ii_sc_geq : + ((bif == num_eq_b_ii) ? opt_b_ii_sc_eq : + (((bif == logbit_b_ii) && (integer(arg2) >= 0) && (integer(arg2) < s7_int_bits)) ? opt_b_ii_sc_bit : + opt_b_ii_sc))))); return(oo_set_type_1(opc, 1, OO_I)); } opc->v[10].o1 = sc->opts[sc->pc]; if (int_optimize(sc, cddr(car_x))) { - opc->v[0].fb = opt_b_ii_sf; + opc->v[0].fb = (bif == num_eq_b_ii) ? opt_b_ii_sf_eq : opt_b_ii_sf; opc->v[11].fi = opc->v[10].o1->v[0].fi; return(oo_set_type_1(opc, 1, OO_I)); } @@ -59530,7 +59700,7 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (is_opt_int(arg2)) { opc->v[2].i = integer(arg2); - opc->v[0].fb = opt_b_ii_fc; + opc->v[0].fb = (bif == num_eq_b_ii) ? opt_b_ii_fc_eq : opt_b_ii_fc; return(oo_set_type_0(opc)); } opc->v[8].o1 = sc->opts[sc->pc]; @@ -59548,24 +59718,15 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer /* -------- b_or|and -------- */ static bool opt_and_bb(opt_info *o) { - o->sc->pc++; if (o->v[3].fb(o->v[2].o1)) - { - o->sc->pc++; - return(o->v[11].fb(o->v[10].o1)); - } - o->sc->pc = o->v[1].i; + return(o->v[11].fb(o->v[10].o1)); return(false); } static bool opt_and_bb1(opt_info *o) { if (o->v[5].fb(o)) - { - o->sc->pc += 2; - return(o->v[11].fb(o->v[10].o1)); - } - o->sc->pc = o->v[4].i; + return(o->v[11].fb(o->v[10].o1)); return(false); } @@ -59575,37 +59736,24 @@ static bool opt_and_any_b(opt_info *o) for (i = 0; i < o->v[1].i; i++) { opt_info *o1; - o->sc->pc++; o1 = o->v[i + 3].o1; if (!o1->v[0].fb(o1)) - { - o->sc->pc = o->v[2].i; - return(false); - } + return(false); } return(true); } static bool opt_or_bb(opt_info *o) { - o->sc->pc++; if (o->v[3].fb(o->v[2].o1)) - { - o->sc->pc = o->v[1].i; - return(true); - } - o->sc->pc++; + return(true); return(o->v[11].fb(o->v[10].o1)); } static bool opt_or_bb1(opt_info *o) { if (o->v[5].fb(o)) - { - o->sc->pc = o->v[4].i; - return(true); - } - o->sc->pc += 2; + return(true); return(o->v[11].fb(o->v[10].o1)); } @@ -59615,13 +59763,9 @@ static bool opt_or_any_b(opt_info *o) for (i = 0; i < o->v[1].i; i++) { opt_info *o1; - o->sc->pc++; o1 = o->v[i + 3].o1; if (o1->v[0].fb(o1)) - { - o->sc->pc = o->v[2].i; - return(true); - } + return(true); } return(false); } @@ -59653,7 +59797,6 @@ static bool opt_b_or_and(s7_scheme *sc, s7_pointer car_x, int32_t len, int32_t i (o1->v[0].fb == opt_b_7pp_ss) || (o1->v[0].fb == opt_lt_b_7pp_ss)) { - opc->v[4].i = sc->pc - 1; opc->v[5].fb = o1->v[0].fb; opc->v[0].fb = (is_and) ? opt_and_bb1 : opt_or_bb1; opc->v[1].p = o1->v[1].p; @@ -59662,7 +59805,6 @@ static bool opt_b_or_and(s7_scheme *sc, s7_pointer car_x, int32_t len, int32_t i return(oo_set_type_2(opc, 1, 2, OO_P, OO_P)); } opc->v[0].fb = (is_and) ? opt_and_bb : opt_or_bb; - opc->v[1].i = sc->pc - 1; opc->v[2].o1 = o1; opc->v[3].fb = o1->v[0].fb; return(oo_set_type_0(opc)); @@ -59680,7 +59822,6 @@ static bool opt_b_or_and(s7_scheme *sc, s7_pointer car_x, int32_t len, int32_t i if (is_null(p)) { opc->v[0].fb = (is_and) ? opt_and_any_b : opt_or_any_b; - opc->v[2].i = sc->pc - 1; return(oo_set_type_0(opc)); } return(return_false(sc, car_x, __func__, __LINE__)); @@ -59753,7 +59894,7 @@ static s7_pointer opt_p_7i_c(opt_info *o) {return(make_integer(o->sc, o->v[2].i_ static s7_pointer opt_p_d_c(opt_info *o) {return(make_real(o->sc, o->v[2].d_d_f(o->v[1].x)));} static s7_pointer opt_p_7d_c(opt_info *o) {return(make_real(o->sc, o->v[2].d_7d_f(o->sc, o->v[1].x)));} static s7_pointer opt_p_p_s(opt_info *o) {return(o->v[2].p_p_f(o->sc, slot_value(o->v[1].p)));} -static s7_pointer opt_p_p_f(opt_info *o) {o->sc->pc++; return(o->v[2].p_p_f(o->sc, o->v[4].fp(o->v[3].o1)));} +static s7_pointer opt_p_p_f(opt_info *o) {return(o->v[2].p_p_f(o->sc, o->v[4].fp(o->v[3].o1)));} static s7_pointer opt_p_p_f1(opt_info *o) {return(o->v[2].p_p_f(o->sc, o->v[3].p_p_f(o->sc, slot_value(o->v[1].p))));} static bool p_p_f_combinable(s7_scheme *sc, opt_info *opc) @@ -59775,7 +59916,7 @@ static bool p_p_f_combinable(s7_scheme *sc, opt_info *opc) return(return_false(sc, NULL, __func__, __LINE__)); } -static s7_pointer opt_p_call_f(opt_info *o) {o->sc->pc++; return(o->v[2].call(o->sc, set_plist_1(o->sc, o->v[5].fp(o->v[4].o1))));} +static s7_pointer opt_p_call_f(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, o->v[5].fp(o->v[4].o1))));} static s7_pointer opt_p_call_s(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, slot_value(o->v[1].p))));} static s7_pointer opt_p_call_c(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, o->v[1].p)));} @@ -59901,7 +60042,7 @@ static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c /* -------- p_i -------- */ static s7_pointer opt_p_i_s(opt_info *o) {return(o->v[2].p_i_f(o->sc, integer(slot_value(o->v[1].p))));} -static s7_pointer opt_p_i_f(opt_info *o) {o->sc->pc++; return(o->v[2].p_i_f(o->sc, o->v[4].fi(o->v[3].o1)));} +static s7_pointer opt_p_i_f(opt_info *o) {return(o->v[2].p_i_f(o->sc, o->v[4].fi(o->v[3].o1)));} static bool p_i_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) { @@ -59933,14 +60074,12 @@ static bool p_i_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c /* -------- p_ii -------- */ static s7_pointer opt_p_ii_ss(opt_info *o) {return(o->v[3].p_ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_ii_fs(opt_info *o) {o->sc->pc++; return(o->v[3].p_ii_f(o->sc, o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));} +static s7_pointer opt_p_ii_fs(opt_info *o) {return(o->v[3].p_ii_f(o->sc, o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));} static s7_pointer opt_p_ii_ff(opt_info *o) { s7_int i1; - o->sc->pc++; i1 = o->v[11].fi(o->v[10].o1); - o->sc->pc++; return(o->v[3].p_ii_f(o->sc, i1, o->v[9].fi(o->v[8].o1))); } @@ -59996,7 +60135,7 @@ static bool p_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer /* -------- p_d -------- */ static s7_pointer opt_p_d_s(opt_info *o) {return(o->v[2].p_d_f(o->sc, real_to_double(o->sc, slot_value(o->v[1].p), "p_d")));} -static s7_pointer opt_p_d_f(opt_info *o) {o->sc->pc++; return(o->v[2].p_d_f(o->sc, o->v[4].fd(o->v[3].o1)));} +static s7_pointer opt_p_d_f(opt_info *o) {return(o->v[2].p_d_f(o->sc, o->v[4].fd(o->v[3].o1)));} static bool p_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) { @@ -60075,8 +60214,8 @@ static bool p_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer /* -------- p_pi -------- */ static s7_pointer opt_p_pi_ss(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} static s7_pointer opt_p_pi_sc(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o->v[2].i));} -static s7_pointer opt_p_pi_sf(opt_info *o) {o->sc->pc++; return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} -static s7_pointer opt_p_pi_fc(opt_info *o) {o->sc->pc++; return(o->v[3].p_pi_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].i));} +static s7_pointer opt_p_pi_sf(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} +static s7_pointer opt_p_pi_fc(opt_info *o) {return(o->v[3].p_pi_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].i));} static bool p_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer sig, s7_pointer car_x) { @@ -60195,17 +60334,15 @@ static bool p_pi_fc_combinable(s7_scheme *sc, opt_info *opc) static s7_pointer opt_p_pp_ss(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} static s7_pointer opt_p_pp_sc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[2].p));} static s7_pointer opt_p_pp_cs(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[2].p, slot_value(o->v[1].p)));} -static s7_pointer opt_p_pp_sf(opt_info *o) {o->sc->pc++; return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_fs(opt_info *o) {o->sc->pc++; return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} -static s7_pointer opt_p_pp_fc(opt_info *o) {o->sc->pc++; return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].p));} +static s7_pointer opt_p_pp_sf(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} +static s7_pointer opt_p_pp_fs(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} +static s7_pointer opt_p_pp_fc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].p));} static s7_pointer opt_p_pp_cc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[1].p, o->v[2].p));} static s7_pointer opt_p_pp_ff(opt_info *o) { s7_pointer p1; - o->sc->pc++; p1 = o->v[11].fp(o->v[10].o1); - o->sc->pc++; return(o->v[3].p_pp_f(o->sc, p1, o->v[9].fp(o->v[8].o1))); } @@ -60262,7 +60399,7 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if ((!is_pair(caddr(car_x))) || (is_proper_quote(sc, caddr(car_x)))) { - opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadr(caddr(car_x)); + opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x); opc->v[0].fp = opt_p_pp_sc; return(oo_set_type_1(opc, 1, OO_P)); } @@ -60286,7 +60423,7 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer ((!is_pair(caddr(car_x))) || (is_proper_quote(sc, caddr(car_x))))) { - opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadr(caddr(car_x)); + opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x); opc->v[0].fp = opt_p_pp_cc; return(oo_set_type_0(opc)); } @@ -60340,7 +60477,7 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer return(true); } } - opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadr(caddr(car_x)); + opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x); opc->v[0].fp = opt_p_pp_fc; opc->v[4].o1 = o1; opc->v[5].fp = o1->v[0].fp; @@ -60371,9 +60508,7 @@ static s7_pointer opt_p_call_ff(opt_info *o) #if S7_DEBUGGING if (sc->stack_end >= sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: skipped stack resize\n", __func__, __LINE__); #endif - sc->pc++; gc_protect_direct(sc, o->v[11].fp(o->v[10].o1)); - sc->pc++; po2 = o->v[9].fp(o->v[8].o1); po2 = o->v[3].call(sc, set_plist_2(sc, sc->stack_end[-2], po2)); sc->stack_end -= 4; @@ -60383,7 +60518,6 @@ static s7_pointer opt_p_call_ff(opt_info *o) static s7_pointer opt_p_call_fs(opt_info *o) { s7_pointer po1; - o->sc->pc++; po1 = o->v[11].fp(o->v[10].o1); return(o->v[3].call(o->sc, set_plist_2(o->sc, po1, slot_value(o->v[1].p)))); } @@ -60391,7 +60525,6 @@ static s7_pointer opt_p_call_fs(opt_info *o) static s7_pointer opt_p_call_sf(opt_info *o) { s7_pointer po1; - o->sc->pc++; po1 = o->v[11].fp(o->v[10].o1); return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), po1))); } @@ -60477,33 +60610,15 @@ static bool p_call_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poi /* -------- p_pip --------*/ -static s7_pointer opt_p_pip_ssf(opt_info *o) -{ - o->sc->pc++; - return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1))); -} - -static s7_pointer opt_p_pip_sss(opt_info *o) -{ - return(o->v[4].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), slot_value(o->v[3].p))); -} - -static s7_pointer opt_p_pip_ssc(opt_info *o) -{ - return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].p)); -} - -static s7_pointer opt_p_pip_c(opt_info *o) -{ - return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].p_p_f(o->sc, o->v[4].p))); -} +static s7_pointer opt_p_pip_ssf(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1)));} +static s7_pointer opt_p_pip_sss(opt_info *o) {return(o->v[4].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), slot_value(o->v[3].p)));} +static s7_pointer opt_p_pip_ssc(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].p));} +static s7_pointer opt_p_pip_c(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].p_p_f(o->sc, o->v[4].p)));} static s7_pointer opt_p_pip_sff(opt_info *o) { s7_int i1; - o->sc->pc++; i1 = o->v[11].fi(o->v[10].o1); - o->sc->pc++; return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), i1, o->v[9].fp(o->v[8].o1))); } @@ -60517,7 +60632,6 @@ static s7_pointer opt_p_pip_sso(opt_info *o) static s7_pointer opt_p_pip_ssf1(opt_info *o) { - o->sc->pc += 2; return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].p_p_f(o->sc, o->v[6].fp(o->v[5].o1)))); } @@ -60733,7 +60847,6 @@ static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer /* -------- p_piip -------- */ static s7_pointer opt_p_piip_sssf(opt_info *o) { - o->sc->pc++; return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[11].fp(o->v[10].o1))); } @@ -60745,11 +60858,8 @@ static s7_pointer opt_p_piip_sssc(opt_info *o) static s7_pointer opt_p_piip_sfff(opt_info *o) { s7_int i1, i2; - o->sc->pc++; i1 = o->v[11].fi(o->v[10].o1); - o->sc->pc++; i2 = o->v[9].fi(o->v[8].o1); - o->sc->pc++; return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), i1, i2, o->v[3].fp(o->v[4].o1))); /* v[3] because v[5] is already in use */ } @@ -60774,7 +60884,7 @@ static bool p_piip_to_sx(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s7_po opc->v[0].fp = opt_p_piip_sssf; return(oo_set_type_3(opc, 1, 2, 3, (is_typed_vector(obj)) ? OO_TV : OO_PV, OO_I, OO_I)); } - return(return_false(sc, car_x, __func__, __LINE__)); + return(return_false(sc, indexp1, __func__, __LINE__)); } opc->v[0].fp = opt_p_piip_sssc; opc->v[4].p = (is_pair(car(valp))) ? cadar(valp) : car(valp); @@ -60795,7 +60905,7 @@ static bool p_piip_to_sx(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s7_po opc->v[0].fp = opt_p_piip_sfff; return(oo_set_type_1(opc, 1, (is_typed_vector(obj)) ? OO_TV : OO_PV)); }}}} - return(return_false(sc, car_x, __func__, __LINE__)); + return(return_false(sc, indexp1, __func__, __LINE__)); } static bool p_piip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) @@ -60833,9 +60943,7 @@ static s7_pointer opt_p_pii_sss(opt_info *o) static s7_pointer opt_p_pii_sff(opt_info *o) { s7_int i1, i2; - o->sc->pc++; i1 = o->v[11].fi(o->v[10].o1); - o->sc->pc++; i2 = o->v[9].fi(o->v[8].o1); return(o->v[4].p_pii_f(o->sc, slot_value(o->v[1].p), i1, i2)); } @@ -60889,11 +60997,7 @@ static bool p_pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } /* -------- p_ppi -------- */ -static s7_pointer opt_p_ppi_psf(opt_info *o) -{ - o->sc->pc++; - return(o->v[3].p_ppi_f(o->sc, o->v[2].p, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1))); -} +static s7_pointer opt_p_ppi_psf(opt_info *o) {return(o->v[3].p_ppi_f(o->sc, o->v[2].p, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} static bool p_ppi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) { @@ -60926,9 +61030,9 @@ static bool p_ppi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } /* -------- p_ppp -------- */ -static s7_pointer opt_p_ppp_ssf(opt_info *o) {o->sc->pc++; return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_ppp_hash_increment(opt_info *o) {o->sc->pc = o->v[4].i; return(fx_hash_increment_1(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].p));} -static s7_pointer opt_p_ppp_sfs(opt_info *o) {o->sc->pc++; return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p)));} +static s7_pointer opt_p_ppp_ssf(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].fp(o->v[4].o1)));} +static s7_pointer opt_p_ppp_hash_increment(opt_info *o) {return(fx_hash_increment_1(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].p));} +static s7_pointer opt_p_ppp_sfs(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p)));} static s7_pointer opt_p_ppp_scs(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[4].p, slot_value(o->v[2].p)));} static s7_pointer opt_p_ppp_sss(opt_info *o) {return(o->v[4].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)));} static s7_pointer opt_p_ppp_ssc(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[4].p));} @@ -60936,9 +61040,7 @@ static s7_pointer opt_p_ppp_ssc(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot static s7_pointer opt_p_ppp_sff(opt_info *o) { s7_pointer po1; - o->sc->pc++; po1 = o->v[11].fp(o->v[10].o1); - o->sc->pc++; return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), po1, o->v[9].fp(o->v[8].o1))); } @@ -60950,11 +61052,8 @@ static s7_pointer opt_p_ppp_fff(opt_info *o) #if S7_DEBUGGING if (sc->stack_end >= sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: skipped stack resize\n", __func__, __LINE__); #endif - sc->pc++; gc_protect_direct(sc, T_Pos(o->v[11].fp(o->v[10].o1))); - sc->pc++; sc->stack_end[-4] = T_Pos(o->v[9].fp(o->v[8].o1)); - sc->pc++; res = o->v[3].p_ppp_f(sc, sc->stack_end[-2], sc->stack_end[-4], o->v[5].fp(o->v[4].o1)); sc->stack_end -= 4; return(res); @@ -61053,7 +61152,6 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (optimize_op(car_x) == OP_HASH_INCREMENT) { opc->v[0].fp = opt_p_ppp_hash_increment; - opc->v[4].i = sc->pc - 1; opc->v[5].p = car_x; return(oo_set_type_2(opc, 1, 2, op2, OO_P)); } @@ -61145,7 +61243,6 @@ static s7_pointer opt_p_call_sss(opt_info *o) static s7_pointer opt_p_call_ssf(opt_info *o) { - o->sc->pc++; return(o->v[4].call(o->sc, set_plist_3(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[6].fp(o->v[5].o1)))); } @@ -61154,14 +61251,11 @@ static s7_pointer opt_p_call_ppp(opt_info *o) s7_pointer res; s7_scheme *sc; sc = o->sc; - sc->pc++; #if S7_DEBUGGING if (sc->stack_end >= sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: skipped stack resize\n", __func__, __LINE__); #endif gc_protect_direct(sc, o->v[4].fp(o->v[3].o1)); - sc->pc++; sc->stack_end[-4] = o->v[6].fp(o->v[5].o1); - sc->pc++; res = o->v[11].fp(o->v[10].o1); /* not combinable into next */ res = o->v[2].call(sc, set_plist_3(sc, sc->stack_end[-2], sc->stack_end[-4], res)); sc->stack_end -= 4; @@ -61235,16 +61329,15 @@ static bool p_call_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_po opc->v[10].o1 = o3; opc->v[11].fp = o3->v[0].fp; return(oo_set_type_0(opc)); - } - } - } - } + }}}} pc_fallback(sc, start); return(return_false(sc, car_x, __func__, __LINE__)); } /* -------- p_call_any -------- */ +#define P_CALL_O1 3 + static s7_pointer opt_p_call_any(opt_info *o) { s7_pointer arg, val; @@ -61257,7 +61350,7 @@ static s7_pointer opt_p_call_any(opt_info *o) for (i = 0, arg = val; i < o->v[1].i; i++, arg = cdr(arg)) { opt_info *o1; - o1 = sc->opts[++sc->pc]; /* 3..15 */ + o1 = o->v[i + P_CALL_O1].o1; set_car(arg, o1->v[0].fp(o1)); } arg = o->v[2].call(sc, val); @@ -61273,15 +61366,20 @@ static s7_pointer opt_p_call_any(opt_info *o) static bool p_call_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t len) { - if ((is_safe_procedure(s_func)) && + if ((len < 12) && + (is_safe_procedure(s_func)) && (c_function_required_args(s_func) <= (len - 1)) && (c_function_all_args(s_func) >= (len - 1))) { s7_pointer p; /* (vector-set! v k i 2) gets here */ + int32_t pctr; opc->v[1].i = (len - 1); - for (p = cdr(car_x); is_pair(p); p = cdr(p)) - if (!cell_optimize(sc, p)) - break; + for (pctr = P_CALL_O1, p = cdr(car_x); is_pair(p); pctr++, p = cdr(p)) + { + opc->v[pctr].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + } if (is_null(p)) { opc->v[0].fp = opt_p_call_any; @@ -61483,25 +61581,31 @@ static bool p_implicit(s7_scheme *sc, s7_pointer car_x, int32_t len) pc_fallback(sc, start); } - opc->v[1].i = len; - for (p = car_x; is_pair(p); p = cdr(p)) - if (!cell_optimize(sc, p)) - break; - if (is_null(p)) + if (len < 11) /* mimic p_call_any_ok */ { - opc->v[0].fp = opt_p_call_any; - switch (type(obj)) /* string can't happen here (no multidimensional strings) */ + int32_t pctr; + opc->v[1].i = len; + for (pctr = 3, p = car_x; is_pair(p); pctr++, p = cdr(p)) { - case T_PAIR: opc->v[2].call = g_list_ref; break; - case T_HASH_TABLE: opc->v[2].call = g_hash_table_ref; break; - /* case T_LET: opc->v[2].call = g_let_ref; break; */ /* this doesn't handle implicit indices via g_let_ref! apply_let */ - case T_INT_VECTOR: opc->v[2].call = g_int_vector_ref; break; - case T_FLOAT_VECTOR: opc->v[2].call = g_float_vector_ref; break; - case T_VECTOR: opc->v[2].call = g_vector_ref; break; - default: return(return_false(sc, car_x, __func__, __LINE__)); + opc->v[pctr].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; } - return(oo_set_type_0(opc)); - }}} + if (is_null(p)) + { + opc->v[0].fp = opt_p_call_any; + switch (type(obj)) /* string can't happen here (no multidimensional strings) */ + { + case T_PAIR: opc->v[2].call = g_list_ref; break; + case T_HASH_TABLE: opc->v[2].call = g_hash_table_ref; break; + /* case T_LET: opc->v[2].call = g_let_ref; break; */ /* this doesn't handle implicit indices via g_let_ref! apply_let */ + case T_INT_VECTOR: opc->v[2].call = g_int_vector_ref; break; + case T_FLOAT_VECTOR: opc->v[2].call = g_float_vector_ref; break; + case T_VECTOR: opc->v[2].call = g_vector_ref; break; + default: return(return_false(sc, car_x, __func__, __LINE__)); + } + return(oo_set_type_0(opc)); + }}}} } /* obj is sequence */ } return(return_false(sc, car_x, __func__, __LINE__)); @@ -61523,7 +61627,6 @@ static bool opt_cell_quote(s7_scheme *sc, s7_pointer car_x) static s7_pointer opt_set_p_p_f(opt_info *o) { s7_pointer x; - o->sc->pc++; x = o->v[4].fp(o->v[3].o1); slot_set_value(o->v[1].p, x); return(x); @@ -61542,7 +61645,6 @@ static s7_pointer opt_set_p_i_s(opt_info *o) static s7_pointer opt_set_p_i_f(opt_info *o) { s7_pointer x; - o->sc->pc++; x = make_integer(o->sc, o->v[6].fi(o->v[5].o1)); slot_set_value(o->v[1].p, x); return(x); @@ -61561,7 +61663,6 @@ static s7_pointer opt_set_p_d_s(opt_info *o) static s7_pointer opt_set_p_d_f(opt_info *o) { s7_pointer x; - o->sc->pc++; x = make_real(o->sc, o->v[5].fd(o->v[4].o1)); slot_set_value(o->v[1].p, x); return(x); @@ -61703,7 +61804,7 @@ static bool is_some_number(s7_scheme *sc, s7_pointer tp) static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer car_x, opt_info *opc, int32_t start_pc) { - /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, DISPLAY(sc->code)); */ + /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(sc->code)); */ /* maybe the type uncertainty is not a problem */ if ((is_pair(sc->code)) && /* t101-aux-14: (vector-set! !v! 0 (do ((x (list 1 2 3) (cdr x)) (j -1)) ((null? x) j) (set! j (car x)))) */ @@ -61745,7 +61846,6 @@ static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer } } } - /* fprintf(stderr, "unhappy %s\n", DISPLAY_80(sc->code)); */ return(return_false(sc, car_x, __func__, __LINE__)); } @@ -61785,7 +61885,6 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy { opc->v[2].p = val_slot; opc->v[0].fp = opt_set_p_i_s; - fprintf(stderr, "expr: %s\n", DISPLAY(car_x)); return(oo_set_type_2(opc, 1, 2, OO_I, OO_I)); } } @@ -61977,6 +62076,26 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy if (is_pair(cddr(target))) return(return_false(sc, car_x, __func__, __LINE__)); op2 = OO_L; opc->v[3].p_pip_f = list_set_p_pip_direct; + + /* an experiment -- is this ever hit in normal code? */ + { + s7_pointer val; + val = caddr(car_x); + if ((is_pair(val)) && (car(val) == sc->add_symbol) && (is_t_integer(caddr(val))) && (is_null(cdddr(val))) && (is_symbol(cadr(target))) && + (car(target) == (caadr(val))) && (is_pair(cdadr(val))) && (is_null(cddadr(val))) && (cadr(target) == cadadr(val))) + { + s7_pointer slot; + index = cadr(target); + slot = opt_simple_symbol(sc, index); + if ((slot) && (is_opt_int(slot_value(slot)))) + { + opc->v[2].p = slot; + opc->v[3].p = caddr(val); + opc->v[0].fp = list_increment_p_pip_direct; + return(oo_set_type_2(opc, 1, 2, op2, OO_I)); + } + } + } break; case T_HASH_TABLE: @@ -62075,7 +62194,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy { if (!is_pair(caddr(car_x))) opc->v[4].p = caddr(car_x); - else opc->v[4].p = cadr(caddr(car_x)); + else opc->v[4].p = cadaddr(car_x); if ((is_string(obj)) || (is_any_vector(obj)) || (is_pair(obj))) @@ -62176,34 +62295,20 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy static s7_pointer opt_begin_p(opt_info *o) { opt_info *o1; - s7_int i, k, len; - s7_scheme *sc; - sc = o->sc; - len = o->v[1].i; /* len = 1 if 2 exprs, etc */ - if (len < 5) - { - for (i = 0, k = 2; i < len; i++, k += 2) - { - sc->pc++; - o->v[k + 1].fp(o->v[k].o1); - } - sc->pc++; - return(o->v[k + 1].fp(o->v[k].o1)); - } + s7_int i, len; + len = o->v[1].i; /* len = 1 if 2 exprs, etc */ for (i = 0; i < len; i++) { - o1 = sc->opts[++sc->pc]; /* 2..15 or does it collide above? */ + o1 = o->v[i + 2].o1; o1->v[0].fp(o1); } - o1 = sc->opts[++sc->pc]; + o1 = o->v[i + 2].o1; return(o1->v[0].fp(o1)); } static s7_pointer opt_begin_p_1(opt_info *o) { - o->sc->pc++; o->v[3].fp(o->v[2].o1); - o->sc->pc++; return(o->v[5].fp(o->v[4].o1)); } @@ -62238,8 +62343,10 @@ static bool opt_cell_begin(s7_scheme *sc, s7_pointer car_x, int32_t len) int32_t i; opt_info *opc; s7_pointer p; + if (len > 12) + return(return_false(sc, car_x, __func__, __LINE__)); opc = alloc_opo(sc, car_x); - for (i = 2, p = cdr(car_x); is_pair(p); i += 2, p = cdr(p)) + for (i = 2, p = cdr(car_x); is_pair(p); i++, p = cdr(p)) { opt_info *start; start = sc->opts[sc->pc]; @@ -62247,88 +62354,78 @@ static bool opt_cell_begin(s7_scheme *sc, s7_pointer car_x, int32_t len) return(return_false(sc, car_x, __func__, __LINE__)); if (is_pair(cdr(p))) oo_idp_nr_fixup(start); - if (i < 12) - { - opc->v[i].o1 = start; - opc->v[i + 1].fp = start->v[0].fp; - } + opc->v[i].o1 = start; } opc->v[1].i = len - 2; - opc->v[0].fp = (len == 3) ? opt_begin_p_1 : opt_begin_p; + if (len == 3) + { + opc->v[0].fp = opt_begin_p_1; + opc->v[4].o1 = opc->v[3].o1; + opc->v[5].fp = opc->v[4].o1->v[0].fp; + opc->v[3].fp = opc->v[2].o1->v[0].fp; + } + else opc->v[0].fp = opt_begin_p; return(oo_set_type_0(opc)); } /* -------- cell_when|unless -------- */ static s7_pointer opt_when_p_2(opt_info *o) { - s7_scheme *sc; - sc = o->sc; - sc->pc++; - if (o->v[11].fb(o->v[10].o1)) + if (o->v[4].fb(o->v[3].o1)) { - opt_info *o1; - o1 = sc->opts[++sc->pc]; - o1->v[0].fp(o1); - o1 = sc->opts[++sc->pc]; - return(o1->v[0].fp(o1)); + o->v[6].fp(o->v[5].o1); + return(o->v[8].fp(o->v[7].o1)); } - sc->pc = o->v[3].i; - return(sc->unspecified); + return(o->sc->unspecified); } static s7_pointer opt_when_p(opt_info *o) { - s7_scheme *sc; - sc = o->sc; - sc->pc++; - if (o->v[11].fb(o->v[10].o1)) + if (o->v[4].fb(o->v[3].o1)) { int32_t i, len; opt_info *o1; len = o->v[1].i - 1; for (i = 0; i < len; i++) { - o1 = sc->opts[++sc->pc]; /* 4..15 */ + o1 = o->v[i + 5].o1; o1->v[0].fp(o1); } - o1 = sc->opts[++sc->pc]; + o1 = o->v[i + 5].o1; return(o1->v[0].fp(o1)); } - sc->pc = o->v[3].i; - return(sc->unspecified); + return(o->sc->unspecified); } static s7_pointer opt_unless_p(opt_info *o) { opt_info *o1; int32_t i, len; - s7_scheme *sc; - sc = o->sc; - sc->pc++; - if (o->v[11].fb(o->v[10].o1)) - { - sc->pc = o->v[3].i; - return(sc->unspecified); - } + + if (o->v[4].fb(o->v[3].o1)) + return(o->sc->unspecified); len = o->v[1].i - 1; for (i = 0; i < len; i++) { - o1 = sc->opts[++sc->pc]; /* 4..15 */ + o1 = o->v[i + 5].o1; o1->v[0].fp(o1); } - o1 = sc->opts[++sc->pc]; + o1 = o->v[i + 5].o1; return(o1->v[0].fp(o1)); } static bool opt_cell_when(s7_scheme *sc, s7_pointer car_x, int32_t len) { s7_pointer p; + int32_t k; opt_info *opc; + if (len > 9) + return(return_false(sc, car_x, __func__, __LINE__)); opc = alloc_opo(sc, car_x); - opc->v[10].o1 = sc->opts[sc->pc]; + opc->v[3].o1 = sc->opts[sc->pc]; if (!bool_optimize(sc, cdr(car_x))) return(return_false(sc, car_x, __func__, __LINE__)); - for (p = cddr(car_x); is_pair(p); p = cdr(p)) + for (k = 5, p = cddr(car_x); is_pair(p); k++, p = cdr(p)) { opt_info *start; start = sc->opts[sc->pc]; @@ -62336,91 +62433,88 @@ static bool opt_cell_when(s7_scheme *sc, s7_pointer car_x, int32_t len) return(return_false(sc, car_x, __func__, __LINE__)); if (is_pair(cdr(p))) oo_idp_nr_fixup(start); + opc->v[k].o1 = start; } - opc->v[11].fb = opc->v[10].o1->v[0].fb; + opc->v[4].fb = opc->v[3].o1->v[0].fb; opc->v[1].i = len - 2; - opc->v[3].i = sc->pc - 1; - opc->v[0].fp = ((car(car_x) == sc->when_symbol) ? ((len == 4) ? opt_when_p_2 : opt_when_p) : opt_unless_p); + if (car(car_x) == sc->when_symbol) + { + if (len == 4) + { + opc->v[0].fp = opt_when_p_2; + opc->v[7].o1 = opc->v[6].o1; + opc->v[8].fp = opc->v[7].o1->v[0].fp; + opc->v[6].fp = opc->v[5].o1->v[0].fp; + } + else opc->v[0].fp = opt_when_p; + } + else opc->v[0].fp = opt_unless_p; return(oo_set_type_0(opc)); } /* -------- cell_cond -------- */ -static s7_pointer opt_cond(opt_info *o) -{ - o->v[2].p = o->sc->unspecified; - while (o->sc->pc < o->v[1].i) - { - opt_info *o1; - o1 = o->sc->opts[++o->sc->pc]; /* 3..15? */ - o1->v[0].fp(o1); - } - return(o->v[2].p); -} -static s7_pointer case_value(opt_info *o) +#define COND_O1 3 +#define COND_CLAUSE_O1 5 + +static s7_pointer cond_value(opt_info *o) { - opt_info *top, *o1; + opt_info *o1; int32_t i, len; - s7_scheme *sc; - sc = o->sc; - top = (opt_info *)(o->v[5].obj); len = o->v[1].i - 1; for (i = 0; i < len; i++) { - o1 = sc->opts[++sc->pc]; /* 6..15 */ + o1 = o->v[i + COND_CLAUSE_O1].o1; o1->v[0].fp(o1); } - o1 = sc->opts[++sc->pc]; - top->v[2].p = o1->v[0].fp(o1); - sc->pc = top->v[1].i; - return(top->v[2].p); + o1 = o->v[i + COND_CLAUSE_O1].o1; + return(o1->v[0].fp(o1)); } -static s7_pointer opt_cond_clause(opt_info *o) +static s7_pointer opt_cond(opt_info *top) { - /* top->p1 gets result, top->i1 is end index, o->v[3].i is end of current clause, o->v[1].i = body len */ - opt_info *o1; - o1 = o->sc->opts[++o->sc->pc]; - if (o1->v[0].fb(o1)) - return(case_value(o)); - o->sc->pc = o->v[3].i; - return(o->sc->unspecified); + int32_t clause, len; + len = top->v[2].i; + for (clause = 0; clause < len; clause++) + { + opt_info *o1, *o2; + o1 = top->v[clause + COND_O1].o1; + o2 = o1->v[4].o1; + if (o2->v[0].fb(o2)) + { + s7_pointer res; + res = cond_value(o1); + return(res); + } + } + return(top->sc->unspecified); } static s7_pointer opt_cond_1(opt_info *o) /* cond as when */ { - o->sc->pc += 2; if (o->v[5].fb(o->v[4].o1)) - return(case_value(o->v[6].o1)); - o->sc->pc = o->v[3].i; + return(cond_value(o->v[6].o1)); return(o->sc->unspecified); } -static s7_pointer opt_cond_2(opt_info *o) +static s7_pointer opt_cond_2(opt_info *o) /* 2 branches, results 1 expr, else */ { - /* 2 branches, results 1 expr, else */ - opt_info *o1, *o2; + opt_info *o1; s7_pointer res; - s7_scheme *sc; - sc = o->sc; - sc->pc += 2; - o2 = sc->opts[sc->pc]; /* this is the boolean expr of the first clause */ - if (!o2->v[0].fb(o2)) - sc->pc = o->v[3].i; /* jump over first clause and #t */ - o1 = sc->opts[++sc->pc]; + if (!o->v[5].fb(o->v[4].o1)) + o1 = o->v[7].o1; + else o1 = o->v[6].o1; res = o1->v[0].fp(o1); - sc->pc = o->v[1].i; /* end of cond index */ return(res); } static bool opt_cell_cond(s7_scheme *sc, s7_pointer car_x) { - /* top->v[2].p gets result, top->v[1].i is end index, clause->v[3].i is end of current clause, - * clause->v[1].i = clause result len, clause->v[5].obj = top - */ + /* top->v[1].i is end index, clause->v[3].i is end of current clause, clause->v[1].i = clause result len */ s7_pointer p, last_clause = NULL; opt_info *top; int32_t branches = 0, max_blen = 0, start_pc; + top = alloc_opo(sc, car_x); start_pc = sc->pc; for (p = cdr(car_x); is_pair(p); p = cdr(p), branches++) @@ -62429,40 +62523,33 @@ static bool opt_cell_cond(s7_scheme *sc, s7_pointer car_x) s7_pointer clause, cp; int32_t blen; clause = car(p); - if ((!is_pair(clause)) || + if ((branches > 12) || + (!is_pair(clause)) || (!is_pair(cdr(clause))) || /* leave the test->result case for later */ (cadr(clause) == sc->feed_to_symbol)) return(return_false(sc, clause, __func__, __LINE__)); last_clause = clause; + top->v[branches + COND_O1].o1 = sc->opts[sc->pc]; opc = alloc_opo(sc, car_x); oo_set_type_0(opc); - if ((car(clause) == sc->else_symbol) || - (car(clause) == sc->T)) - { - opt_info *opb; - opb = alloc_opo(sc, clause); - opb->v[0].fb = opt_b_t; - oo_set_type_0(opb); - } - else + opc->v[4].o1 = sc->opts[sc->pc]; + + if (!bool_optimize(sc, clause)) + return(return_false(sc, clause, __func__, __LINE__)); + + for (blen = 0, cp = cdr(clause); is_pair(cp); blen++, cp = cdr(cp)) { - if (!bool_optimize(sc, clause)) - return(return_false(sc, clause, __func__, __LINE__)); + opc->v[blen + COND_CLAUSE_O1].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cp)) + return(return_false(sc, cp, __func__, __LINE__)); } - for (blen = 0, cp = cdr(clause); is_pair(cp); blen++, cp = cdr(cp)) - if (!cell_optimize(sc, cp)) - return(return_false(sc, cp, __func__, __LINE__)); if (!is_null(cp)) return(return_false(sc, cp, __func__, __LINE__)); opc->v[1].i = blen; if (max_blen < blen) max_blen = blen; - opc->v[3].i = sc->pc - 1; - opc->v[5].obj = (void *)top; - opc->v[0].fp = opt_cond_clause; + opc->v[0].fp = opt_cond; /* a placeholder */ } - top->v[1].i = sc->pc - 1; - top->v[0].fp = opt_cond; if (branches == 1) { opt_info *o1; @@ -62480,24 +62567,26 @@ static bool opt_cell_cond(s7_scheme *sc, s7_pointer car_x) (car(last_clause) == sc->T))) { opt_info *o1; - o1 = sc->opts[start_pc]; - top->v[3].i = o1->v[3].i + 2; + top->v[6].o1 = top->v[COND_O1].o1->v[COND_CLAUSE_O1].o1; + top->v[7].o1 = top->v[1 + COND_O1].o1->v[COND_CLAUSE_O1].o1; + + o1 = sc->opts[start_pc + 1]; + top->v[4].o1 = o1; + top->v[5].fb = o1->v[0].fb; top->v[0].fp = opt_cond_2; + return(oo_set_type_0(top)); } } + top->v[2].i = branches; + top->v[0].fp = opt_cond; return(oo_set_type_0(top)); } /* -------- cell_and|or -------- */ static s7_pointer opt_and_pp(opt_info *o) { - o->sc->pc++; if (o->v[11].fp(o->v[10].o1) == o->sc->F) - { - o->sc->pc = o->v[1].i; - return(o->sc->F); - } - o->sc->pc++; + return(o->sc->F); return(o->v[9].fp(o->v[8].o1)); } @@ -62509,18 +62598,10 @@ static s7_pointer opt_and_any_p(opt_info *o) for (i = 0; i < o->v[1].i; i++) { opt_info *o1; - /* o1 = o->sc->opts[++o->sc->pc]; *//* 3..15? */ - o->sc->pc++; o1 = o->v[i + 3].o1; -#if S7_DEBUGGING - if (o1 != o->sc->opts[o->sc->pc]) fprintf(stderr, "and o1 != opts\n"); -#endif val = o1->v[0].fp(o1); if (val == o->sc->F) - { - o->sc->pc = o->v[2].i; - return(o->sc->F); - } + return(o->sc->F); } return(val); } @@ -62528,14 +62609,9 @@ static s7_pointer opt_and_any_p(opt_info *o) static s7_pointer opt_or_pp(opt_info *o) { s7_pointer val; - o->sc->pc++; val = o->v[11].fp(o->v[10].o1); if (val != o->sc->F) - { - o->sc->pc = o->v[1].i; - return(val); - } - o->sc->pc++; + return(val); return(o->v[9].fp(o->v[8].o1)); } @@ -62546,24 +62622,14 @@ static s7_pointer opt_or_any_p(opt_info *o) { s7_pointer val; opt_info *o1; - o->sc->pc++; o1 = o->v[i + 3].o1; -#if S7_DEBUGGING - if (o1 != o->sc->opts[o->sc->pc]) fprintf(stderr, "or o1 != opts\n"); -#endif - /* o1 = o->sc->opts[++o->sc->pc]; */ /* 3..15? */ val = o1->v[0].fp(o1); if (val != o->sc->F) - { - o->sc->pc = o->v[2].i; - return(val); - } + return(val); } return(o->sc->F); } -/* static s7_pointer b_to_p_0(opt_info *o) {return((o->v[0].fb(o)) ? o->sc->T : o->sc->F);} */ - static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len) { opt_info *opc; @@ -62581,8 +62647,6 @@ static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len) if (!cell_optimize(sc, cddr(car_x))) return(return_false(sc, car_x, __func__, __LINE__)); opc->v[9].fp = opc->v[8].o1->v[0].fp; - - opc->v[1].i = sc->pc - 1; return(oo_set_type_0(opc)); } @@ -62599,8 +62663,6 @@ static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len) if (!cell_optimize(sc, p)) return(return_false(sc, car_x, __func__, __LINE__)); } - - opc->v[2].i = sc->pc - 1; return(oo_set_type_0(opc)); } return(return_false(sc, car_x, __func__, __LINE__)); @@ -62609,166 +62671,99 @@ static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len) /* -------- cell_if -------- */ static s7_pointer opt_if_bp(opt_info *o) { - o->sc->pc++; if (o->v[3].fb(o->v[2].o1)) - { - o->sc->pc++; - return(o->v[5].fp(o->v[4].o1)); - } - o->sc->pc = o->v[1].i; + return(o->v[5].fp(o->v[4].o1)); return(o->sc->unspecified); } static s7_pointer opt_if_bp_nr(opt_info *o) { - o->sc->pc++; if (o->v[3].fb(o->v[2].o1)) - { - o->sc->pc++; - return(o->v[5].fp(o->v[4].o1)); - } + return(o->v[5].fp(o->v[4].o1)); return(NULL); } static s7_pointer opt_if_bp_pb(opt_info *o) /* p_to_b at outer */ { - o->sc->pc++; if (o->v[3].fp(o->v[2].o1) != o->sc->F) /* this is p_to_b expanded and moved to o[3] */ - { - o->sc->pc++; - return(o->v[5].fp(o->v[4].o1)); - } - o->sc->pc = o->v[1].i; + return(o->v[5].fp(o->v[4].o1)); return(o->sc->unspecified); } static s7_pointer opt_if_bp_ii_fc(opt_info *o) { - o->sc->pc += 2; if (o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i)) - { - o->sc->pc++; - return(o->v[5].fp(o->v[4].o1)); - } - o->sc->pc = o->v[1].i; + return(o->v[5].fp(o->v[4].o1)); return(o->sc->unspecified); } static s7_pointer opt_if_nbp(opt_info *o) { - o->sc->pc++; if (!o->v[5].fb(o->v[4].o1)) - { - o->sc->pc++; - return(o->v[11].fp(o->v[10].o1)); - } - o->sc->pc = o->v[1].i; + return(o->v[11].fp(o->v[10].o1)); return(o->sc->unspecified); } static s7_pointer opt_if_nbp_s(opt_info *o) { if (!(o->v[2].b_p_f(slot_value(o->v[3].p)))) - { - o->sc->pc += 2; - return(o->v[11].fp(o->v[10].o1)); - } - o->sc->pc = o->v[1].i; + return(o->v[11].fp(o->v[10].o1)); return(o->sc->unspecified); } static s7_pointer opt_if_nbp_sc(opt_info *o) /* b_pp_sc */ { if (!(o->v[3].b_pp_f(slot_value(o->v[2].p), o->v[4].p))) - { - o->sc->pc += 2; - return(o->v[11].fp(o->v[10].o1)); - } - o->sc->pc = o->v[1].i; + return(o->v[11].fp(o->v[10].o1)); return(o->sc->unspecified); } static s7_pointer opt_if_nbp_7sc(opt_info *o) /* b_7pp_sc */ { if (!(o->v[3].b_7pp_f(o->sc, slot_value(o->v[2].p), o->v[4].p))) - { - o->sc->pc += 2; - return(o->v[11].fp(o->v[10].o1)); - } - o->sc->pc = o->v[1].i; + return(o->v[11].fp(o->v[10].o1)); return(o->sc->unspecified); } static s7_pointer opt_if_nbp_ss(opt_info *o) /* b_ii_ss */ { if (!(o->v[3].b_ii_f(integer(slot_value(o->v[2].p)), integer(slot_value(o->v[4].p))))) - { - o->sc->pc += 2; - return(o->v[11].fp(o->v[10].o1)); - } - o->sc->pc = o->v[1].i; + return(o->v[11].fp(o->v[10].o1)); return(o->sc->unspecified); } static s7_pointer opt_if_nbp_fs(opt_info *o) { - o->sc->pc += 2; if (!(o->v[2].b_pi_f(o->sc, o->v[5].fp(o->v[4].o1), integer(slot_value(o->v[3].p))))) /* b_pi_fs */ - { - o->sc->pc++; - return(o->v[11].fp(o->v[10].o1)); - } - o->sc->pc = o->v[1].i; + return(o->v[11].fp(o->v[10].o1)); return(o->sc->unspecified); } static s7_pointer opt_if_nbp_fs_nr(opt_info *o) { - /* not o->sc->pc += 2 as above because sc->pc is preset to 2 (far) below */ if (!(o->v[2].b_pi_f(o->sc, o->v[5].fp(o->v[4].o1), integer(slot_value(o->v[3].p))))) /* b_pi_fs */ - { - o->sc->pc++; - return(o->v[11].fp(o->v[10].o1)); - } + return(o->v[11].fp(o->v[10].o1)); return(NULL); } static s7_pointer opt_if_nbp_sf(opt_info *o) { - o->sc->pc += 2; if (!(o->v[2].b_pp_f(slot_value(o->v[3].p), o->v[5].fp(o->v[4].o1)))) /* b_pp_sf */ - { - o->sc->pc++; - return(o->v[11].fp(o->v[10].o1)); - } - o->sc->pc = o->v[1].i; + return(o->v[11].fp(o->v[10].o1)); return(o->sc->unspecified); } static s7_pointer opt_if_nbp_7sf(opt_info *o) { - o->sc->pc += 2; if (!(o->v[2].b_7pp_f(o->sc, slot_value(o->v[3].p), o->v[5].fp(o->v[4].o1)))) /* b_7pp_sf */ - { - o->sc->pc++; - return(o->v[11].fp(o->v[10].o1)); - } - o->sc->pc = o->v[1].i; + return(o->v[11].fp(o->v[10].o1)); return(o->sc->unspecified); } static s7_pointer opt_if_bpp(opt_info *o) { - o->sc->pc++; if (o->v[5].fb(o->v[4].o1)) - { - s7_pointer val; - o->sc->pc++; - val = o->v[9].fp(o->v[8].o1); - o->sc->pc = o->v[3].i; - return(val); - } - o->sc->pc = o->v[1].i; + return(o->v[9].fp(o->v[8].o1)); return(o->v[11].fp(o->v[10].o1)); } @@ -62787,7 +62782,6 @@ static bool opt_cell_if(s7_scheme *sc, s7_pointer car_x, int32_t len) top = sc->opts[sc->pc]; if (cell_optimize(sc, cddr(car_x))) { - opc->v[1].i = sc->pc - 1; opc->v[10].o1 = top; opc->v[11].fp = top->v[0].fp; @@ -62867,7 +62861,6 @@ static bool opt_cell_if(s7_scheme *sc, s7_pointer car_x, int32_t len) top = sc->opts[sc->pc]; if (cell_optimize(sc, cddr(car_x))) { - opc->v[1].i = sc->pc - 1; opc->v[2].o1 = bop; opc->v[4].o1 = top; opc->v[5].fp = top->v[0].fp; @@ -62904,10 +62897,8 @@ static bool opt_cell_if(s7_scheme *sc, s7_pointer car_x, int32_t len) opt_info *o3; o3 = sc->opts[sc->pc]; opc->v[0].fp = opt_if_bpp; - opc->v[1].i = sc->pc; if (cell_optimize(sc, cdddr(car_x))) { - opc->v[3].i = sc->pc - 1; opc->v[4].o1 = bop; opc->v[5].fb = bop->v[0].fb; opc->v[8].o1 = top; @@ -62935,43 +62926,56 @@ static bool case_memv(s7_scheme *sc, s7_pointer x, s7_pointer y) return(false); } -static s7_pointer opt_case(opt_info *o) +#define CASE_O1 3 +#define CASE_SEL 2 +#define CASE_CLAUSE_O1 4 +#define CASE_CLAUSE_KEYS 2 + +static s7_pointer case_value(s7_scheme *sc, opt_info *top, opt_info *o) { opt_info *o1; - o->v[2].p = o->sc->unspecified; - o1 = o->sc->opts[++o->sc->pc]; - o->v[4].p = o1->v[0].fp(o1); - while (o->sc->pc < o->v[1].i) + int32_t i, len; + len = o->v[1].i - 1; + for (i = 0; i < len; i++) { - o1 = o->sc->opts[++o->sc->pc]; /* 5..15? */ + o1 = o->v[i + CASE_CLAUSE_O1].o1; o1->v[0].fp(o1); } - return(o->v[2].p); + o1 = o->v[i + CASE_CLAUSE_O1].o1; + return(o1->v[0].fp(o1)); } -static s7_pointer opt_case_clause(opt_info *o) +static s7_pointer opt_case(opt_info *o) { - /* top->v[2].p gets result, top->i1 is end index, top->v[4].p is selector, o->v[3].i is end of current clause, o->v[1].i = body len */ - opt_info *top; - top = (opt_info *)(o->v[5].obj); - if ((o->v[2].p == o->sc->else_symbol) || - (case_memv(o->sc, top->v[4].p, o->v[2].p))) - return(case_value(o)); - o->sc->pc = o->v[3].i; + opt_info *o1; + int32_t ctr, lim; + s7_pointer selector; + + o1 = o->v[CASE_SEL].o1; + selector = o1->v[0].fp(o1); + lim = o->v[1].i; + + for (ctr = CASE_O1; ctr < lim; ctr++) + { + o1 = o->v[ctr].o1; + if ((o1->v[CASE_CLAUSE_KEYS].p == o->sc->else_symbol) || + (case_memv(o->sc, selector, o1->v[CASE_CLAUSE_KEYS].p))) + return(case_value(o->sc, o, o1)); + } return(o->sc->unspecified); } static bool opt_cell_case(s7_scheme *sc, s7_pointer car_x) { - /* top->v[2].p gets result, top->v[1].i is end index, clause->v[3].i is end of current clause, - * clause->v[1].i = clause result len, clause->v[5].obj = top - */ + /* top->v[1].i is end index, clause->v[3].i is end of current clause, clause->v[1].i = clause result len */ opt_info *top; top = alloc_opo(sc, car_x); + top->v[CASE_SEL].o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cdr(car_x))) /* selector */ { s7_pointer p; - for (p = cddr(car_x); is_pair(p); p = cdr(p)) + int32_t ctr; + for (ctr = CASE_O1, p = cddr(car_x); (is_pair(p)) && (ctr < 15); ctr++, p = cdr(p)) { opt_info *opc; s7_pointer clause, cp; @@ -62984,33 +62988,35 @@ static bool opt_cell_case(s7_scheme *sc, s7_pointer car_x) return(return_false(sc, clause, __func__, __LINE__)); opc = alloc_opo(sc, car_x); + top->v[ctr].o1 = opc; if (car(clause) == sc->else_symbol) { if (!is_null(cdr(p))) return(return_false(sc, clause, __func__, __LINE__)); - opc->v[2].p = sc->else_symbol; + opc->v[CASE_CLAUSE_KEYS].p = sc->else_symbol; } else { if (!s7_is_proper_list(sc, car(clause))) return(return_false(sc, clause, __func__, __LINE__)); - opc->v[2].p = car(clause); + opc->v[CASE_CLAUSE_KEYS].p = car(clause); + } + + for (blen = 0, cp = cdr(clause); (is_pair(cp)) && (blen < 12); blen++, cp = cdr(cp)) + { + opc->v[blen + CASE_CLAUSE_O1].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cp)) + return(return_false(sc, cp, __func__, __LINE__)); } - - for (blen = 0, cp = cdr(clause); is_pair(cp); blen++, cp = cdr(cp)) - if (!cell_optimize(sc, cp)) - return(return_false(sc, cp, __func__, __LINE__)); if (!is_null(cp)) return(return_false(sc, cp, __func__, __LINE__)); opc->v[1].i = blen; - opc->v[3].i = sc->pc - 1; - opc->v[5].obj = (void *)top; - opc->v[0].fp = opt_case_clause; + opc->v[0].fp = opt_case; /* just a placeholder I hope */ oo_set_type_0(opc); } if (!is_null(p)) return(return_false(sc, p, __func__, __LINE__)); - top->v[1].i = sc->pc - 1; + top->v[1].i = ctr; top->v[0].fp = opt_case; return(oo_set_type_0(top)); } @@ -63018,34 +63024,35 @@ static bool opt_cell_case(s7_scheme *sc, s7_pointer car_x) } /* -------- cell_let_temporarily -------- */ + +#define LET_TEMP_O1 5 + static s7_pointer opt_let_temporarily(opt_info *o) { opt_info *o1; int32_t i, len; s7_pointer result; + #if S7_DEBUGGING if (cur_sc->stack_end >= cur_sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: skipped stack resize\n", __func__, __LINE__); #endif - o1 = o->sc->opts[++o->sc->pc]; - o->v[4].p = slot_value(o->v[1].p); /* save and protect old value */ - gc_protect_direct(o->sc, o->v[4].p); - if (is_immutable_slot(o->v[1].p)) immutable_object_error(o->sc, set_elist_3(o->sc, immutable_error_string, o->sc->let_temporarily_symbol, slot_symbol(o->v[1].p))); - slot_set_value(o->v[1].p, o1->v[0].fp(o1)); /* set new value */ + o1 = o->v[4].o1; + o->v[3].p = slot_value(o->v[1].p); /* save and protect old value */ + gc_protect_direct(o->sc, o->v[3].p); + slot_set_value(o->v[1].p, o1->v[0].fp(o1)); /* set new value */ len = o->v[2].i - 1; for (i = 0; i < len; i++) { - o1 = o->sc->opts[++o->sc->pc]; /* 5..15? */ + o1 = o->v[i + LET_TEMP_O1].o1; o1->v[0].fp(o1); } - o1 = o->sc->opts[++o->sc->pc]; + o1 = o->v[i + LET_TEMP_O1].o1; result = o1->v[0].fp(o1); - - slot_set_value(o->v[1].p, o->v[4].p); /* restore old */ + slot_set_value(o->v[1].p, o->v[3].p); /* restore old */ o->sc->stack_end -= 4; - return(result); } @@ -63056,7 +63063,8 @@ static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer car_x, int32_t le return(return_false(sc, car_x, __func__, __LINE__)); vars = cadr(car_x); - if ((is_proper_list_1(sc, vars)) && /* just one var for now */ + if ((len < 10) && + (is_proper_list_1(sc, vars)) && /* just one var for now */ (is_proper_list_2(sc, car(vars))) && /* and var is (sym val) */ (is_symbol(caar(vars))) && (!is_immutable(caar(vars))) && @@ -63064,16 +63072,22 @@ static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer car_x, int32_t le { s7_pointer p; opt_info *opc; + int32_t i; opc = alloc_opo(sc, car_x); opc->v[1].p = symbol_to_slot(sc, caar(cadr(car_x))); if (!is_slot(opc->v[1].p)) return(return_false(sc, car_x, __func__, __LINE__)); + opc->v[4].o1 = sc->opts[sc->pc]; if (!cell_optimize(sc, cdar(cadr(car_x)))) return(return_false(sc, car_x, __func__, __LINE__)); - for (p = cddr(car_x); is_pair(p); p = cdr(p)) - if (!cell_optimize(sc, p)) - return(return_false(sc, car_x, __func__, __LINE__)); + + for (i = LET_TEMP_O1, p = cddr(car_x); is_pair(p); i++, p = cdr(p)) + { + opc->v[i].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return(return_false(sc, car_x, __func__, __LINE__)); + } opc->v[2].i = len - 2; opc->v[0].fp = opt_let_temporarily; @@ -63084,12 +63098,30 @@ static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer car_x, int32_t le /* -------- cell_do -------- */ +static void let_set_has_pending_value(s7_pointer lt) +{ + s7_pointer vp; + for (vp = let_slots(lt); tis_slot(vp); vp = next_slot(vp)) + { + if (!slot_pending_value_unchecked(vp)) + slot_set_pending_value(vp, eof_object); + else slot_set_has_pending_value(vp); + } +} + +static void let_clear_has_pending_value(s7_pointer lt) +{ + s7_pointer vp; + for (vp = let_slots(lt); tis_slot(vp); vp = next_slot(vp)) + slot_clear_has_pending_value(vp); +} + static s7_pointer opt_do_any(opt_info *o) { /* o->v[2].p=frame, o->v[1].i=body end index, o->v[3].i=body length, o->v[4].i=return length, o->v[5].i=end index */ - opt_info *o1, *ostart; - int32_t loop, i; + opt_info *o1, *ostart, *body, *inits, *steps, *results; + int32_t i, k; s7_pointer vp, old_e, result; s7_scheme *sc; @@ -63099,14 +63131,19 @@ static s7_pointer opt_do_any(opt_info *o) sc->envir = T_Let(o->v[2].p); /* init */ - for (vp = let_slots(sc->envir); tis_slot(vp); vp = next_slot(vp)) + inits = o->v[7].o1; + for (k = 0, vp = let_slots(sc->envir); tis_slot(vp); k++, vp = next_slot(vp)) { - o1 = sc->opts[++sc->pc]; + o1 = inits->v[k].o1; slot_set_value(vp, o1->v[0].fp(o1)); } - loop = ++sc->pc; - ostart = sc->opts[loop]; + ostart = o->v[12].o1; + body = o->v[10].o1; + results = o->v[11].o1; + steps = o->v[13].o1; + let_set_has_pending_value(sc->envir); + while (true) { /* end */ @@ -63116,33 +63153,30 @@ static s7_pointer opt_do_any(opt_info *o) /* body */ for (i = 0; i < o->v[3].i; i++) { - o1 = sc->opts[++sc->pc]; + o1 = body->v[i].o1; o1->v[0].fp(o1); } /* step (let not let*) */ - for (vp = let_slots(sc->envir); tis_slot(vp); vp = next_slot(vp)) + for (k = 0, vp = let_slots(sc->envir); tis_slot(vp); k++, vp = next_slot(vp)) if (has_stepper(vp)) { - o1 = sc->opts[++sc->pc]; - slot_set_pending_value(vp, o1->v[0].fp(o1)); + o1 = steps->v[k].o1; + slot_simply_set_pending_value(vp, o1->v[0].fp(o1)); } for (vp = let_slots(sc->envir); tis_slot(vp); vp = next_slot(vp)) if (has_stepper(vp)) slot_set_value(vp, slot_pending_value(vp)); - - sc->pc = loop; } - sc->pc = o->v[1].i; /* result */ result = sc->T; for (i = 0; i < o->v[4].i; i++) { - o1 = sc->opts[++sc->pc]; + o1 = results->v[i].o1; result = o1->v[0].fp(o1); } - sc->pc = o->v[5].i; + let_clear_has_pending_value(sc->envir); unstack(sc); sc->envir = old_e; return(result); @@ -63151,8 +63185,8 @@ static s7_pointer opt_do_any(opt_info *o) static s7_pointer opt_do_step_1(opt_info *o) { /* 1 stepper (multi inits perhaps), 1 body, 1 rtn */ - opt_info *o1, *ostart, *ostep; - int32_t loop; + opt_info *o1, *ostart, *ostep, *inits, *body; + int32_t k; s7_pointer vp, old_e, result, stepper = NULL; s7_scheme *sc; @@ -63162,28 +63196,25 @@ static s7_pointer opt_do_step_1(opt_info *o) push_stack_no_let_no_code(sc, OP_GC_PROTECT, old_e); sc->envir = T_Let(o->v[2].p); - for (vp = let_slots(sc->envir); tis_slot(vp); vp = next_slot(vp)) + inits = o->v[7].o1; + for (k = 0, vp = let_slots(sc->envir); tis_slot(vp); k++, vp = next_slot(vp)) { - o1 = sc->opts[++sc->pc]; + o1 = inits->v[k].o1; slot_set_value(vp, o1->v[0].fp(o1)); if (has_stepper(vp)) stepper = vp; } - loop = ++sc->pc; - ostart = sc->opts[loop]; + ostart = o->v[12].o1; + body = o->v[10].o1; + while (true) { if (ostart->v[0].fb(ostart)) break; - o1 = sc->opts[++sc->pc]; - o1->v[0].fp(o1); - sc->pc++; + body->v[0].fp(body); slot_set_value(stepper, ostep->v[0].fp(ostep)); - sc->pc = loop; } - sc->pc = o->v[1].i; - o1 = sc->opts[++sc->pc]; + o1 = o->v[11].o1; result = o1->v[0].fp(o1); - sc->pc = o->v[5].i; unstack(sc); sc->envir = old_e; return(result); @@ -63191,44 +63222,41 @@ static s7_pointer opt_do_step_1(opt_info *o) static s7_pointer opt_do_no_vars(opt_info *o) { - /* no vars, no return, o->v[2].p=frame, o->v[1].i=body end index, o->v[3].i=body length, o->v[4].i=return length, o->v[5].i=end index */ + /* no vars, no return, o->v[2].p=frame, o->v[1].i=body end index, o->v[3].i=body length, o->v[4].i=return length=0, o->v[5].i=end index, 6=end test */ opt_info *ostart; - int32_t loop, len; + int32_t len; s7_pointer old_e; s7_scheme *sc; + bool (*fb)(opt_info *o); sc = o->sc; old_e = sc->envir; push_stack_no_let_no_code(sc, OP_GC_PROTECT, old_e); sc->envir = o->v[2].p; len = o->v[3].i; + ostart = o->v[6].o1; + fb = ostart->v[0].fb; - loop = ++sc->pc; - ostart = sc->opts[loop]; - if (len == 0) + if (len == 0) /* titer */ { - while (true) - { - if (ostart->v[0].fb(ostart)) break; - sc->pc = loop; - } + while (true) {if (fb(ostart)) break;} } else { - while (true) + opt_info *body; + body = o->v[7].o1; + while (true) /* tshoot, tfft */ { int32_t i; - if (ostart->v[0].fb(ostart)) break; + if (fb(ostart)) break; for (i = 0; i < len; i++) { opt_info *o1; - o1 = sc->opts[++sc->pc]; + o1 = body->v[i].o1; o1->v[0].fp(o1); } - sc->pc = loop; } } - sc->pc = o->v[5].i; unstack(sc); sc->envir = old_e; return(sc->T); @@ -63237,8 +63265,7 @@ static s7_pointer opt_do_no_vars(opt_info *o) static s7_pointer opt_do_1(opt_info *o) { /* 1 var, 1 expr, no return */ - opt_info *o1, *ostart, *ostep; /* o->v[2].p=frame, o->v[5].i=end index */ - int32_t loop; + opt_info *o1, *ostart, *ostep, *body; /* o->v[2].p=frame, o->v[5].i=end index */ s7_pointer vp, old_e; s7_scheme *sc; sc = o->sc; @@ -63249,16 +63276,15 @@ static s7_pointer opt_do_1(opt_info *o) ostep = o->v[9].o1; vp = let_slots(o->v[2].p); - o1 = sc->opts[++sc->pc]; + o1 = o->v[11].o1; slot_set_value(vp, o1->v[0].fp(o1)); - - loop = ++sc->pc; - ostart = sc->opts[loop]; + ostart = o->v[12].o1; + body = o->v[10].o1; if ((o->v[8].i == 1) && (is_t_integer(slot_value(vp)))) { - if (ostep->v[0].fp == opt_p_ii_ss_add) + if (ostep->v[0].fp == opt_p_ii_ss_add) /* tmap */ { s7_pointer step_val; step_val = make_mutable_integer(sc, integer(slot_value(vp))); @@ -63266,12 +63292,9 @@ static s7_pointer opt_do_1(opt_info *o) while (true) { if (ostart->v[0].fb(ostart)) break; - o1 = sc->opts[++sc->pc]; - o1->v[0].fp(o1); + body->v[0].fp(body); integer(step_val) = opt_i_ii_ss_add(ostep); - sc->pc = loop; } - sc->pc = o->v[5].i; unstack(sc); sc->envir = old_e; return(sc->T); @@ -63279,22 +63302,17 @@ static s7_pointer opt_do_1(opt_info *o) else { #if S7_DEBUGGING && (0) - fprintf(stderr, "%s: not add: %s\n", __func__, DISPLAY(o->vexpr)); + fprintf(stderr, "%s: not add: %s\n", __func__, display(o->expr)); #endif o->v[8].i = 2; } } - - while (true) + while (true) /* s7test tref */ { if (ostart->v[0].fb(ostart)) break; - o1 = sc->opts[++sc->pc]; - o1->v[0].fp(o1); - sc->pc++; + body->v[0].fp(body); slot_set_value(vp, ostep->v[0].fp(ostep)); - sc->pc = loop; } - sc->pc = o->v[5].i; unstack(sc); sc->envir = old_e; return(sc->T); @@ -63303,8 +63321,8 @@ static s7_pointer opt_do_1(opt_info *o) static s7_pointer opt_do_n(opt_info *o) { /* 1 var, no return */ - opt_info *o1, *ostart, *ostep; /* o->v[2].p=frame, o->v[3].i=body length, o->v[5].i=end index */ - int32_t loop, len; + opt_info *o1, *ostart, *ostep, *body; /* o->v[2].p=frame, o->v[3].i=body length, o->v[5].i=end index */ + int32_t len; s7_pointer vp, old_e; s7_scheme *sc; sc = o->sc; @@ -63316,44 +63334,37 @@ static s7_pointer opt_do_n(opt_info *o) len = o->v[3].i; vp = let_slots(o->v[2].p); - o1 = sc->opts[++sc->pc]; + o1 = o->v[11].o1; slot_set_value(vp, o1->v[0].fp(o1)); + ostart = o->v[12].o1; + body = o->v[7].o1; - loop = ++sc->pc; - ostart = sc->opts[loop]; - if (len == 2) + if (len == 2) /* tmac tshoot */ { opt_info *e1, *e2; - e1 = o->v[10].o1; - e2 = o->v[11].o1; + e1 = body->v[0].o1; + e2 = body->v[1].o1; while (true) { if (ostart->v[0].fb(ostart)) break; - sc->pc++; e1->v[0].fp(e1); - sc->pc++; e2->v[0].fp(e2); - sc->pc++; slot_set_value(vp, ostep->v[0].fp(ostep)); - sc->pc = loop; } } else { - while (!ostart->v[0].fb(ostart)) + while (!ostart->v[0].fb(ostart)) /* tfft teq */ { int32_t i; for (i = 0; i < len; i++) { - o1 = sc->opts[++sc->pc]; + o1 = body->v[i].o1; o1->v[0].fp(o1); } - sc->pc++; slot_set_value(vp, ostep->v[0].fp(ostep)); - sc->pc = loop; } } - sc->pc = o->v[5].i; unstack(sc); sc->envir = old_e; return(sc->T); @@ -63362,8 +63373,8 @@ static s7_pointer opt_do_n(opt_info *o) static s7_pointer opt_dotimes_2(opt_info *o) { /* 1 var, no return */ - opt_info *o1; /* o->v[2].p=frame, o->v[3].i=body length, o->v[4].i=return length, o->v[5].i=end index, v6.i=end if int32_t */ - int32_t loop, len; + opt_info *o1, *body; /* o->v[2].p=frame, o->v[3].i=body length, o->v[4].i=return length=0, o->v[5].i=end index, v6.i=end, v7=init */ + int32_t len; s7_int end; s7_pointer vp, old_e; s7_scheme *sc; @@ -63379,40 +63390,35 @@ static s7_pointer opt_dotimes_2(opt_info *o) end = integer(slot_value(let_dox_slot2(o->v[2].p))); else end = o->v[6].i; - o1 = sc->opts[++sc->pc]; + o1 = o->v[11].o1; integer(vp) = integer(o1->v[0].fp(o1)); + body = o->v[7].o1; - loop = o->v[4].i - 1; - if (len == 2) + if (len == 2) /* tmac tmisc */ { opt_info *e1, *e2; - loop++; - e1 = o->v[10].o1; - e2 = o->v[11].o1; + e1 = body->v[0].o1; + e2 = body->v[1].o1; while (integer(vp) < end) { - sc->pc = loop; e1->v[0].fp(e1); - sc->pc++; e2->v[0].fp(e2); integer(vp)++; } } else { - while (integer(vp) < end) + while (integer(vp) < end) /* tbig sg */ { int32_t i; - sc->pc = loop; for (i = 0; i < len; i++) { - o1 = sc->opts[++sc->pc]; + o1 = body->v[i].o1; o1->v[0].fp(o1); } integer(vp)++; } } - sc->pc = o->v[5].i; unstack(sc); sc->envir = old_e; return(sc->T); @@ -63422,7 +63428,6 @@ static s7_pointer opt_do_list_simple(opt_info *o) { /* 1 var, 1 expr, no return, step by cdr, end=null? */ opt_info *o1; /* o->v[2].p=frame, o->v[5].i=end index */ - int32_t loop; s7_pointer vp, old_e; s7_scheme *sc; s7_pointer (*fp)(opt_info *o); @@ -63433,21 +63438,17 @@ static s7_pointer opt_do_list_simple(opt_info *o) sc->envir = o->v[2].p; vp = let_slots(o->v[2].p); - o1 = sc->opts[++sc->pc]; + o1 = o->v[11].o1; slot_set_value(vp, o1->v[0].fp(o1)); - - loop = sc->pc + 2; - o1 = sc->opts[loop]; + o1 = o->v[10].o1; fp = o1->v[0].fp; if (fp == opt_if_bp) fp = opt_if_bp_nr; while (!is_null(slot_value(vp))) { - sc->pc = loop; fp(o1); slot_set_value(vp, cdr(slot_value(vp))); } - sc->pc = o->v[5].i; unstack(sc); sc->envir = old_e; return(sc->T); @@ -63457,7 +63458,7 @@ static s7_pointer opt_do_very_simple(opt_info *o) { /* like simple but step can be direct, v[2].p is a let */ opt_info *o1; - s7_int end, loop; + s7_int end; s7_pointer vp, old_e; s7_pointer (*f)(opt_info *o); s7_scheme *sc; @@ -63470,21 +63471,19 @@ static s7_pointer opt_do_very_simple(opt_info *o) if (is_slot(let_dox_slot2_unchecked(o->v[2].p))) end = integer(slot_value(let_dox_slot2(o->v[2].p))); else end = o->v[3].i; - o1 = sc->opts[++sc->pc]; + + o1 = o->v[11].o1; integer(vp) = integer(o1->v[0].fp(o1)); - loop = o->v[4].i; - sc->pc = loop; - o1 = sc->opts[loop]; /* the body */ + o1 = o->v[10].o1; f = o1->v[0].fp; - if (f == opt_p_pip_ssf) + if (f == opt_p_pip_ssf) /* tref.scm */ { opt_info *o; o = o1; - o1 = sc->opts[++loop]; + o1 = o->v[4].o1; while (integer(vp) < end) { - sc->pc = loop; o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o1->v[0].fp(o1)); integer(vp)++; } @@ -63497,44 +63496,43 @@ static s7_pointer opt_do_very_simple(opt_info *o) { o1->v[5].p_pip_f(o1->sc, slot_value(o1->v[1].p), integer(slot_value(o1->v[2].p)), o1->v[6].p_pi_f(o1->sc, slot_value(o1->v[3].p), integer(slot_value(o1->v[4].p)))); - sc->pc = loop; integer(vp)++; } } else { - if ((f == opt_set_p_i_f) && + if ((f == opt_set_p_i_f) && /* tvect.scm */ (is_t_integer(slot_value(o1->v[1].p))) && (o1->v[1].p != let_dox_slot1(o->v[2].p))) { s7_pointer ival; opt_info *o2; + s7_int (*fi)(opt_info *o); ival = make_mutable_integer(sc, integer(slot_value(o1->v[1].p))); slot_set_value(o1->v[1].p, ival); - o2 = sc->opts[++loop]; + o2 = o1->v[5].o1; /* set_p_i_f: x = make_integer(o->sc, o->v[6].fi(o->v[5].o1)); */ + fi = o2->v[0].fi; while (integer(vp) < end) { - sc->pc = loop; - integer(ival) = o2->v[0].fi(o2); + integer(ival) = fi(o2); integer(vp)++; } slot_set_value(o1->v[1].p, make_integer(sc, integer(slot_value(o1->v[1].p)))); } else { - if ((f == opt_d_7pid_ssf_nr) && + if ((f == opt_d_7pid_ssf_nr) && /* tref.scm */ (o1->v[4].d_7pid_f == float_vector_set_unchecked)) { s7_pointer fv, ind; opt_info *o2; s7_double (*fd)(opt_info *o); - o2 = sc->opts[++loop]; + o2 = o1->v[10].o1; fv = slot_value(o1->v[1].p); ind = o1->v[2].p; fd = o2->v[0].fd; while (integer(vp) < end) { - sc->pc = loop; float_vector_set_unchecked(sc, fv, integer(slot_value(ind)), fd(o2)); integer(vp)++; } @@ -63544,10 +63542,8 @@ static s7_pointer opt_do_very_simple(opt_info *o) while (integer(vp) < end) { f(o1); - sc->pc = loop; integer(vp)++; }}}}} - sc->pc = o->v[5].i; unstack(sc); sc->envir = old_e; return(sc->T); @@ -63569,14 +63565,14 @@ static s7_pointer opt_do_prepackaged(opt_info *o) if (is_slot(let_dox_slot2_unchecked(o->v[2].p))) end = integer(slot_value(let_dox_slot2(o->v[2].p))); else end = o->v[3].i; - o1 = sc->opts[++sc->pc]; + + o1 = o->v[11].o1; integer(vp) = integer(o1->v[0].fp(o1)); o->v[6].p = vp; o->v[1].i = end; - o->v[7].fp(o); + o->v[7].fp(o); /* call opt_do_i|dpnr below */ - sc->pc = o->v[5].i; unstack(sc); sc->envir = old_e; return(sc->T); @@ -63585,21 +63581,16 @@ static s7_pointer opt_do_prepackaged(opt_info *o) static s7_pointer opt_do_dpnr(opt_info *o) { opt_info *o1; - int32_t loop; s7_pointer vp; s7_int end; s7_double (*f)(opt_info *o); - s7_scheme *sc; - sc = o->sc; end = o->v[1].i; vp = o->v[6].p; - loop = o->v[4].i; - o1 = sc->opts[loop]; /* the body */ + o1 = o->v[10].o1; /* the body */ f = o1->v[O_WRAP].fd; while (integer(vp) < end) { - sc->pc = loop; f(o1); integer(vp)++; } @@ -63609,53 +63600,22 @@ static s7_pointer opt_do_dpnr(opt_info *o) static s7_pointer opt_do_ipnr(opt_info *o) { opt_info *o1; - int32_t loop; s7_pointer vp; s7_int end; s7_int (*f)(opt_info *o); - s7_scheme *sc; - sc = o->sc; end = o->v[1].i; vp = o->v[6].p; - loop = o->v[4].i; - o1 = sc->opts[loop]; /* the body */ + o1 = o->v[10].o1; /* the body */ f = o1->v[O_WRAP].fi; while (integer(vp) < end) { - sc->pc = loop; f(o1); integer(vp)++; } return(NULL); } -static s7_pointer opt_do_setpif(opt_info *o) -{ - opt_info *o1; - int32_t loop; - s7_pointer vp, val, slot; - s7_int end, arg2; - s7_scheme *sc; - sc = o->sc; - end = o->v[1].i; - vp = o->v[6].p; - loop = o->v[4].i; - o1 = sc->opts[loop]; - arg2 = o->v[3].i; - slot = o1->v[2].p; - - val = make_mutable_integer(sc, integer(slot_value(o1->v[1].p))); - slot_set_value(o1->v[1].p, val); - while (integer(vp) < end) - { - integer(val) = o1->v[4].i_ii_f(integer(slot_value(slot)), arg2); - integer(vp)++; - } - clear_mutable_integer(val); - return(NULL); -} - static bool stop_is_safe(s7_scheme *sc, s7_pointer stop, s7_pointer body) { /* this could be folded into the cell_optimize traveral */ @@ -63684,14 +63644,15 @@ static bool tree_has_setters(s7_scheme *sc, s7_pointer tree) static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_pointer var_list, bool *has_set); +#define SIZE_O NUM_VUNIONS + static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) { opt_info *opc; - s7_pointer p, end, frame = NULL, old_e, slot, stop, ind, ind_step, var; - int32_t i, var_len, body_len, body_index, step_len, rtn_len, step_pc; + s7_pointer p, end, frame = NULL, old_e, slot, stop, ind, ind_step; + int32_t i, k, var_len, body_len, body_index, step_len, rtn_len, step_pc, init_pc, end_test_pc; bool has_set = false; - - /* fprintf(stderr, "%s: %s\n", __func__, DISPLAY_80(car_x)); */ + opt_info *init_o[SIZE_O], *step_o[SIZE_O], *body_o[SIZE_O], *return_o[SIZE_O]; if (len < 3) return(return_false(sc, car_x, __func__, __LINE__)); @@ -63701,6 +63662,8 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) var_len = safe_list_length(cadr(car_x)); step_len = var_len; body_len = len - 3; + if (body_len > SIZE_O) + return(return_false(sc, car_x, __func__, __LINE__)); end = caddr(car_x); if (!is_pair(end)) return(return_false(sc, car_x, __func__, __LINE__)); @@ -63739,10 +63702,13 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) if (tis_slot(let_slots(frame))) let_set_slots(frame, reverse_slots(sc, let_slots(frame))); - for (p = cadr(car_x), slot = let_slots(frame); is_pair(p); p = cdr(p), slot = next_slot(slot)) + /* inits */ + init_pc = sc->pc; + for (k = 0, p = cadr(car_x), slot = let_slots(frame); (is_pair(p)) && (k < SIZE_O); k++, p = cdr(p), slot = next_slot(slot)) { s7_pointer var; var = car(p); + init_o[k] = sc->opts[sc->pc]; if (!cell_optimize(sc, cdr(var))) /* opt init in outer env */ return(return_false(sc, car_x, __func__, __LINE__)); if (is_pair(cddr(var))) @@ -63795,7 +63761,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) (opt_arg_type(sc, cddr(var)) != init_type)) { #if OPT_PRINT - fprintf(stderr, "%s[%d]: init_type: %s, but opt_arg: %s\n", __func__, __LINE__, DISPLAY(init_type), DISPLAY(opt_arg_type(sc, cddr(var)))); + fprintf(stderr, "%s[%d]: init_type: %s, but opt_arg: %s\n", __func__, __LINE__, display(init_type), display(opt_arg_type(sc, cddr(var)))); #endif unstack(sc); /* not pop_stack! */ sc->envir = old_e; @@ -63803,7 +63769,10 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) } } } + if (k != var_len) fprintf(stderr, "inits: %d %d\n", k, var_len); + /* end test */ + end_test_pc = sc->pc; if (!bool_optimize_nw(sc, end)) { unstack(sc); /* not pop_stack! */ @@ -63872,18 +63841,18 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) } } - /* opt body */ + /* body */ body_index = sc->pc; - for (i = 3, p = cdddr(car_x); i < len; i++, p = cdr(p)) + for (k = 0, i = 3, p = cdddr(car_x); i < len; k++, i++, p = cdr(p)) { opt_info *start; start = sc->opts[sc->pc]; + body_o[k] = start; if (i < 5) opc->v[i + 7].o1 = start; if (!cell_optimize(sc, p)) break; oo_idp_nr_fixup(start); } - if (!is_null(p)) { unstack(sc); @@ -63894,17 +63863,17 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) /* we faked up sc->envir above, so s7_optimize_1 (float_optimize) isn't safe here * this means if clm nested loops get here, they aren't fully optimized -- fallback into dox would be better */ + /* steps */ step_pc = sc->pc; - for (p = cadr(car_x); is_pair(p); p = cdr(p)) + for (k = 0, p = cadr(car_x); is_pair(p); k++, p = cdr(p)) { s7_pointer var; var = car(p); - opc->v[9].i = sc->pc; + step_o[k] = sc->opts[sc->pc]; if ((is_pair(cddr(var))) && (!cell_optimize(sc, cddr(var)))) break; } - if (!is_null(p)) { unstack(sc); @@ -63912,35 +63881,48 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) return(return_false(sc, car_x, __func__, __LINE__)); } - rtn_len = 0; - opc->v[1].i = sc->pc - 1; + /* result */ + /* rtn_len = 0; */ if (!is_list(cdr(end))) { unstack(sc); sc->envir = old_e; return(return_false(sc, car_x, __func__, __LINE__)); } - for (p = cdr(end); is_pair(p); p = cdr(p), rtn_len++) - if (!cell_optimize(sc, p)) - break; + for (rtn_len = 0, p = cdr(end); (is_pair(p)) && (rtn_len < SIZE_O); p = cdr(p), rtn_len++) + { + return_o[rtn_len] = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + } if (!is_null(p)) { unstack(sc); sc->envir = old_e; return(return_false(sc, car_x, __func__, __LINE__)); } + opc->v[2].p = frame; opc->v[3].i = len - 3; /* body_len */ opc->v[4].i = rtn_len; - opc->v[5].i = sc->pc - 1; opc->v[9].o1 = sc->opts[step_pc]; sc->envir = old_e; if ((var_len == 0) && (rtn_len == 0)) { + opt_info *body; + opc->v[6].o1 = sc->opts[end_test_pc]; opc->v[0].fp = opt_do_no_vars; + if (body_len > 0) + { + body = alloc_opo(sc, car_x); + for (k = 0; k < body_len; k++) + body->v[k].o1 = body_o[k]; + opc->v[7].o1 = body; + } return(oo_set_type_0(opc)); } + opc->v[8].i = 0; if (body_len == 1) { @@ -63955,19 +63937,66 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) } if ((var_len != 1) || (step_len != 1) || (rtn_len != 0)) { + opt_info *inits; + opc->v[0].fp = ((step_len == 1) && (body_len == 1) && (rtn_len == 1)) ? opt_do_step_1 : opt_do_any; /* (do ((sum 0.0) (k 0 (+ k 1))) ((= k size) (set! (C i j) sum)) (set! sum (+ sum (* (A i k) (B k j))))) tmat */ + opc->v[12].o1 = sc->opts[end_test_pc]; + + inits = alloc_opo(sc, car_x); + for (k = 0; k < var_len; k++) + inits->v[k].o1 = init_o[k]; + opc->v[7].o1 = inits; + + if (opc->v[0].fp == opt_do_any) + { + opt_info *body, *result, *step; + + body = alloc_opo(sc, car_x); + for (k = 0; k < body_len; k++) + body->v[k].o1 = body_o[k]; + opc->v[10].o1 = body; + + result = alloc_opo(sc, car_x); + for (k = 0; k < rtn_len; k++) + result->v[k].o1 = return_o[k]; + opc->v[11].o1 = result; + + step = alloc_opo(sc, car_x); + for (k = 0; k < var_len; k++) + step->v[k].o1 = step_o[k]; + opc->v[13].o1 = step; + } + else + { + opc->v[10].o1 = sc->opts[body_index]; + opc->v[11].o1 = return_o[0]; + } + return(oo_set_type_0(opc)); } opc->v[0].fp = (body_len == 1) ? opt_do_1 : opt_do_n; - - var = caadr(car_x); - ind = car(var); - ind_step = caddr(var); + p = caadr(car_x); + ind = car(p); + ind_step = caddr(p); end = caaddr(car_x); slot = let_slots(frame); + if (body_len == 1) + opc->v[10].o1 = sc->opts[body_index]; + else + { + opt_info *body; + body = alloc_opo(sc, car_x); + for (k = 0; k < body_len; k++) + body->v[k].o1 = body_o[k]; + opc->v[7].o1 = body; + } + opc->v[11].o1 = sc->opts[init_pc]; + opc->v[12].o1 = sc->opts[end_test_pc]; + opc->v[13].o1 = sc->opts[step_pc]; + if ((is_pair(end)) && /* (= i len|100) */ (cadr(end) == ind) && (is_pair(ind_step))) /* (+ i 1) */ @@ -63991,12 +64020,9 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) opc->v[0].fp = opt_do_very_simple; if (is_t_integer(caddr(end))) opc->v[3].i = integer(caddr(end)); - o1 = sc->opts[body_index]; - /* v0..v7 are in use */ - if (o1->v[0].fp == d_to_p_nr) + if (o1->v[0].fp == d_to_p_nr) /* snd-test: (do ((k 0 (+ k 1))) ((= k N)) (float-vector-set! rl k (read-sample rd))) */ { - /* snd-test: (do ((k 0 (+ k 1))) ((= k N)) (float-vector-set! rl k (read-sample rd))) */ opc->v[0].fp = opt_do_prepackaged; opc->v[7].fp = opt_do_dpnr; } @@ -64007,13 +64033,8 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) opc->v[0].fp = opt_do_prepackaged; opc->v[7].fp = opt_do_ipnr; } - else - { - if (o1->v[0].fp == opt_set_p_i_fo1) - { - opc->v[0].fp = opt_do_prepackaged; - opc->v[7].fp = opt_do_setpif; - }}}} + } + } else { opc->v[0].fp = opt_dotimes_2; @@ -64040,7 +64061,8 @@ static bool p_syntax(s7_scheme *sc, s7_pointer car_x, int32_t len) { opcode_t op; s7_pointer func; - func = slot_value(global_slot(car(car_x))); + /* func = slot_value(global_slot(car(car_x))); */ + func = lookup_global(sc, car(car_x)); op = (opcode_t)syntax_opcode(func); switch (op) { @@ -64100,6 +64122,7 @@ static bool p_syntax(s7_scheme *sc, s7_pointer car_x, int32_t len) static bool float_optimize(s7_scheme *sc, s7_pointer expr) { s7_pointer car_x, head; + #if (WITH_GMP) return(return_false(sc, car_x, __func__, __LINE__)); #endif @@ -64190,7 +64213,7 @@ static bool float_optimize(s7_scheme *sc, s7_pointer expr) static bool int_optimize(s7_scheme *sc, s7_pointer expr) { s7_pointer car_x, head; - /* fprintf(stderr, "%s: %s\n", __func__, DISPLAY(expr)); */ + /* fprintf(stderr, "%s: %s\n", __func__, display(expr)); */ #if (WITH_GMP) return(return_false(sc, car_x, __func__, __LINE__)); #endif @@ -64270,7 +64293,7 @@ static bool int_optimize(s7_scheme *sc, s7_pointer expr) static bool cell_optimize(s7_scheme *sc, s7_pointer expr) { s7_pointer car_x, head; - /* fprintf(stderr, "%s: %s, %d\n", __func__, DISPLAY(expr), sc->pc); */ + /* fprintf(stderr, "%s: %s, %d\n", __func__, display(expr), sc->pc); */ car_x = car(expr); if (!is_pair(car_x)) /* wrap constants/symbols */ @@ -64343,10 +64366,7 @@ static bool cell_optimize(s7_scheme *sc, s7_pointer expr) opc->v[O_WRAP].fd = opc->v[0].fd; opc->v[0].fp = d_to_p; return(true); - } - } - } - } + }}}} pc_fallback(sc, pstart); } @@ -64584,7 +64604,6 @@ static s7_function s7_bool_optimize(s7_scheme *sc, s7_pointer expr) if (setjmp(sc->opt_exit) == 0) { sc->pc = 0; - reset_opts(sc); if (bool_optimize(sc, expr)) return(opt_bool_any); } @@ -64599,7 +64618,6 @@ s7_float_function s7_float_optimize(s7_scheme *sc, s7_pointer expr) if (setjmp(sc->opt_exit) == 0) { sc->pc = 0; - reset_opts(sc); if (float_optimize(sc, expr)) return(opt_float_any); } @@ -64617,7 +64635,6 @@ static s7_function s7_optimize_1(s7_scheme *sc, s7_pointer expr, bool nr) if (setjmp(sc->opt_exit) == 0) { sc->pc = 0; - reset_opts(sc); if (!no_int_opt(expr)) { if (int_optimize(sc, expr)) @@ -64641,7 +64658,7 @@ static s7_function s7_optimize_1(s7_scheme *sc, s7_pointer expr, bool nr) } if (cell_optimize(sc, expr)) return((nr) ? opt_cell_any_nr : opt_wrap_cell); - set_no_cell_opt(expr); /* checked elsewhere */ + set_no_cell_opt(expr); /* checked above */ } return(NULL); } @@ -64668,7 +64685,6 @@ static s7_function s7_cell_optimize(s7_scheme *sc, s7_pointer expr, bool nr) if (setjmp(sc->opt_exit) == 0) { sc->pc = 0; - reset_opts(sc); if (cell_optimize(sc, expr)) return((nr) ? opt_cell_any_nr : opt_wrap_cell); } @@ -65012,7 +65028,7 @@ static bool op_for_each(s7_scheme *sc) return(true); } } - push_stack(sc, OP_FOR_EACH, sc->args, sc->code); + push_stack_direct(sc, OP_FOR_EACH, sc->args, sc->code); sc->args = saved_args; if (needs_copied_args(sc->code)) sc->args = copy_list(sc, sc->args); @@ -65091,9 +65107,9 @@ static inline bool op_for_each_2(s7_scheme *sc) sc->args = sc->nil; return(true); } - push_stack(sc, OP_FOR_EACH_2, c, code); + push_stack_direct(sc, OP_FOR_EACH_2, sc->args, sc->code); } - else push_stack(sc, OP_FOR_EACH_3, c, code); + else push_stack_direct(sc, OP_FOR_EACH_3, sc->args, sc->code); if (counter_capture(c) != sc->capture_let_counter) { new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), arg); @@ -65369,7 +65385,7 @@ static bool op_map(s7_scheme *sc) sc->x = cons(sc, x, sc->x); } sc->x = safe_reverse_in_place(sc, sc->x); - push_stack(sc, OP_MAP_GATHER, sc->args, sc->code); + push_stack_direct(sc, OP_MAP_GATHER, sc->args, sc->code); sc->args = sc->x; sc->x = sc->nil; @@ -65394,7 +65410,7 @@ static bool op_map_1(s7_scheme *sc) sc->args = sc->nil; return(true); } - push_stack(sc, OP_MAP_GATHER_1, args, code); + push_stack_direct(sc, OP_MAP_GATHER_1, sc->args, sc->code); if (counter_capture(args) != sc->capture_let_counter) { new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), x); @@ -65446,9 +65462,9 @@ static bool op_map_2(s7_scheme *sc) sc->args = sc->nil; return(true); } - push_stack(sc, OP_MAP_GATHER_2, c, code); + push_stack_direct(sc, OP_MAP_GATHER_2, sc->args, sc->code); } - else push_stack(sc, OP_MAP_GATHER_3, c, code); + else push_stack_direct(sc, OP_MAP_GATHER_3, sc->args, sc->code); if (counter_capture(c) != sc->capture_let_counter) { @@ -65474,7 +65490,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) s7_pointer x; top = s7_stack_top(sc) - 1; /* stack_end - stack_start if negative, we're in big trouble */ #if SHOW_EVAL_OPS - safe_print(fprintf(stderr, "splice %s %s\n", op_names[stack_op(sc->stack, top)], DISPLAY_80(sc->args))); + safe_print(fprintf(stderr, "splice %s %s\n", op_names[stack_op(sc->stack, top)], display_80(sc->args))); #endif switch (stack_op(sc->stack, top)) @@ -65526,11 +65542,8 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_SSP_MV_1; return(args); - case OP_SAFE_C_SP_1: - case OP_SAFE_CONS_SP_1: - case OP_SAFE_ADD_SP_1: - case OP_SAFE_SUBTRACT_SP_1: - case OP_SAFE_MULTIPLY_SP_1: + case OP_SAFE_C_SP_1: case OP_SAFE_CONS_SP_1: + case OP_SAFE_ADD_SP_1: case OP_SAFE_SUBTRACT_SP_1: case OP_SAFE_MULTIPLY_SP_1: stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_SP_MV; return(args); @@ -65556,20 +65569,12 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) stack_element(sc->stack, top) = (s7_pointer)OP_C_AP_MV; return(args); - case OP_SAFE_CLOSURE_P_1: - case OP_CLOSURE_P_1: - stack_element(sc->stack, top) = (s7_pointer)OP_CLOSURE_P_MV; - return(args); - - case OP_SAFE_CLOSURE_AP_1: - case OP_CLOSURE_AP_1: - stack_element(sc->stack, top) = (s7_pointer)OP_CLOSURE_AP_MV; - return(args); - - case OP_SAFE_CLOSURE_PA_1: - case OP_CLOSURE_PA_1: - stack_element(sc->stack, top) = (s7_pointer)OP_CLOSURE_PA_MV; - return(args); + case OP_SAFE_CLOSURE_P_1: case OP_CLOSURE_P_1: + case OP_SAFE_CLOSURE_AP_1: case OP_CLOSURE_AP_1: + case OP_SAFE_CLOSURE_PP_1: case OP_CLOSURE_PP_1: + case OP_SAFE_CLOSURE_PA_1: case OP_CLOSURE_PA_1: /* arity is 2, we have 2 args, this has to be an error (see optimize_func_dotted_args) */ + case OP_SAFE_OR_UNSAFE_CLOSURE_3P_1: case OP_SAFE_OR_UNSAFE_CLOSURE_3P_2: case OP_SAFE_OR_UNSAFE_CLOSURE_3P_3: + return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, stack_code(sc->stack, top), sc->value))); case OP_SAFE_C_PP_1: stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PP_3_MV; @@ -65601,8 +65606,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) /* look for errors here rather than glomming up the set! and let code. */ case OP_SET_SAFE: /* symbol is sc->code after pop */ case OP_SET1: /* (set! var (values 1 2 3)) */ - eval_error_with_caller2(sc, "~A: can't set '~A to ~S", 23, sc->set_symbol, - stack_code(sc->stack, top), cons(sc, sc->values_symbol, args)); + eval_error_with_caller2(sc, "~A: can't set '~A to ~S", 23, sc->set_symbol, stack_code(sc->stack, top), cons(sc, sc->values_symbol, args)); case OP_SET_PAIR_P_1: eval_error(sc, "too many values to set! ~S", 26, cons(sc, sc->values_symbol, args)); @@ -65799,6 +65803,7 @@ static s7_pointer g_list_values(s7_scheme *sc, s7_pointer args) * if the checked bit is on in a macro expansion, that means we're re-expanding this macro, and therefore * have to copy the tree. * we can't set_cdr(pc...) as in earlier versions of this code -- might be an embedded permanent list + * we can't optimize this to list if only constants/symbols in the list because a symbol's value can be #<no-values> */ /* splice out #<values>, (list-values (apply-values ())) -> () etc */ @@ -65927,7 +65932,22 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) - */ if (((check_cycles) && (tree_is_cyclic(sc, form))) || (is_simple_code(sc, form))) - return(list_2(sc, sc->quote_symbol, form)); + { + if ((!is_global(sc->quote_symbol)) && (is_let(sc->envir))) /* in the reader sc->envir can be junk */ + { + s7_pointer quote_val; + quote_val = lookup(sc, sc->quote_symbol); + if (((is_global(sc->quasiquote_symbol)) && + (quote_val == slot_value(global_slot(sc->quasiquote_symbol)))) || + (quote_val == lookup(sc, sc->quasiquote_symbol))) + s7_error(sc, s7_make_symbol(sc, "infinite loop"), + set_elist_2(sc, wrap_string(sc, "quote's value is quasiquote, so '~S is trouble", 46), form)); + /* (member quasiquote (list 1) (lambda 'ho '(1 2))) so '(1 2) -> `(1 2) -> '(1 2)... + * but if we use #_quote above, cycle checks elsewhere get confused (they ignore pairs starting with sc->quote_symbol). + */ + } + return(list_2(sc, sc->quote_symbol, form)); + } { s7_int len, i; @@ -66085,10 +66105,24 @@ static token_t read_sharp(s7_scheme *sc, s7_pointer pt) dig = digits[d]; if (dig >= 10) break; dims = dig + (dims * 10); - if ((dims <= 0) || - (dims > S7_SHORT_MAX)) - s7_error(sc, sc->read_error_symbol, - set_elist_2(sc, wrap_string(sc, "overflow while reading #nD: ~A", 30), wrap_integer1(sc, dims))); + if (dims <= 0) + { + sc->strbuf[loc++] = (unsigned char)d; + s7_error(sc, sc->read_error_symbol, + set_elist_3(sc, wrap_string(sc, "reading #~A...: ~A must be a positive integer", 37), + wrap_string(sc, sc->strbuf, loc), + wrap_integer1(sc, dims))); + } + if (dims > sc->max_vector_dimensions) + { + sc->strbuf[loc++] = (unsigned char)d; + sc->strbuf[loc + 1] = '\0'; + s7_error(sc, sc->read_error_symbol, + set_elist_4(sc, wrap_string(sc, "reading #~A...: ~A is too large, (*s7* 'max-vector-dimensions): ~A", 66), + wrap_string(sc, sc->strbuf, loc), + wrap_integer1(sc, dims), + wrap_integer2(sc, sc->max_vector_dimensions))); + } sc->strbuf[loc++] = (unsigned char)d; } sc->strbuf[loc++] = d; @@ -66960,7 +66994,7 @@ static s7_pointer g_format_as_objstr(s7_scheme *sc, s7_pointer args) obj = caddr(args); if ((!has_active_methods(sc, obj)) || - ((func = find_method(sc, find_let(sc, obj), sc->format_symbol)) == sc->undefined)) + ((func = find_method_with_let(sc, obj, sc->format_symbol)) == sc->undefined)) return(s7_object_to_string(sc, obj, false)); return(s7_apply_function(sc, func, list_3(sc, sc->F, cadr(args), obj))); @@ -67100,7 +67134,6 @@ static s7_pointer hash_table_set_chooser(s7_scheme *sc, s7_pointer f, int32_t ar (cadr(or1) == cadr(expr)) && (caddr(or1) == caddr(expr))) { /* (hash-table-set! counts p (+ (or (hash-table-ref counts p) 0) 1)) -- ssa_direct and hop_safe_c_ss */ - /* fprintf(stderr, "%s: %s %s\n", DISPLAY(expr), op_names[optimize_op(expr)], op_names[optimize_op(or1)]); */ set_optimize_op(expr, OP_HASH_INCREMENT); } } @@ -67495,7 +67528,9 @@ static s7_pointer make_function_with_class(s7_scheme *sc, s7_pointer cls, const int32_t required_args, int32_t optional_args, bool rest_arg) { s7_pointer uf; - /* the "safe_function" business here doesn't matter -- this is after the optimizer decides what is safe */ +#if S7_DEBUGGING + if (!is_safe_procedure(slot_value(global_slot(s7_make_symbol(sc, name))))) fprintf(stderr, "%s unsafe: %s\n", __func__, name); +#endif uf = s7_make_safe_function(sc, name, f, required_args, optional_args, rest_arg, NULL); s7_function_set_class(uf, cls); c_function_signature(uf) = c_function_signature(cls); @@ -67775,6 +67810,7 @@ static void annotate_arg(s7_scheme *sc, s7_pointer arg, s7_pointer e) /* if sc->envir is sc->nil, we're at the top-level, but the global_slot check should suffice for that */ #if S7_DEBUGGING s7_function fx; + /* fprintf(stderr, " %s: %s\n", __func__, display_80(arg)); */ if (has_fx(arg)) return; fx = fx_choose(sc, arg, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe); if (fx) set_c_call(arg, fx); @@ -67788,6 +67824,7 @@ static void annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e) s7_pointer p; for (p = args; is_pair(p); p = cdr(p)) { + /* if (is_unquoted_pair(car(p))) annotate_args(sc, car(p), e); */ #if S7_DEBUGGING annotate_arg(sc, p, e); #else @@ -67799,7 +67836,7 @@ static void annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e) static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e) { #if OPTIMIZE_PRINT - fprintf(stderr, "%s: %s %d\n", __func__, DISPLAY(expr), hop); + fprintf(stderr, "%s: %s %d\n", __func__, display(expr), hop); #endif if (is_constant_symbol(sc, car(expr))) hop = 1; @@ -67872,7 +67909,7 @@ static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int static opt_t optimize_func_dotted_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, s7_pointer e) { - if (fx_count(sc, expr) == args) /* fx_count starts at cdr */ + if (fx_count(sc, expr) == args) /* fx_count starts at cdr, args here is the number of exprs in cdr(expr) -- so this means "are all args fxable" */ { annotate_args(sc, cdr(expr), e); set_opt3_arglen(expr, small_int(args)); @@ -67899,9 +67936,10 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb case OP_SAFE_C_SS: return(OP_SAFE_C_opSSq); case OP_SAFE_C_SC: return(OP_SAFE_C_opSCq); case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq); - case OP_SAFE_C_opSq: return(OP_SAFE_C_op_opSq_q); - case OP_SAFE_C_S_opSq: return(OP_SAFE_C_op_S_opSq_q); - case OP_SAFE_C_opSq_S: return(OP_SAFE_C_op_opSq_S_q); + case OP_SAFE_C_opSq: return(OP_SAFE_C_op_opSqq); + case OP_SAFE_C_opSq_C: return(OP_SAFE_C_op_opSq_Cq); + case OP_SAFE_C_S_opSq: return(OP_SAFE_C_op_S_opSqq); + case OP_SAFE_C_opSq_S: return(OP_SAFE_C_op_opSq_Sq); case OP_SAFE_C_A: return(OP_SAFE_C_opAq); case OP_SAFE_C_AA: return(OP_SAFE_C_opAAq); case OP_SAFE_C_AAA: return(OP_SAFE_C_opAAAq); @@ -67959,7 +67997,7 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb case OP_SAFE_C_A: return(OP_SAFE_C_opAq_S); case OP_SAFE_C_opSSq: set_opt1_pair(cdr(expr), cadadr(expr)); - return(OP_SAFE_C_op_opSSq_q_S); + return(OP_SAFE_C_op_opSSqq_S); case OP_SAFE_C_opSSq_S: set_opt3_pair(expr, cadadr(expr)); return(OP_SAFE_C_op_opSSq_Sq_S); @@ -67977,8 +68015,8 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb return(OP_SAFE_C_opSq_C); case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq_C); case OP_SAFE_C_SC: return(OP_SAFE_C_opSCq_C); - case OP_SAFE_C_opSq: return(OP_SAFE_C_op_opSq_q_C); - case OP_SAFE_C_opSSq: return(OP_SAFE_C_op_opSSq_q_C); + case OP_SAFE_C_opSq: return(OP_SAFE_C_op_opSqq_C); + case OP_SAFE_C_opSSq: return(OP_SAFE_C_op_opSSqq_C); case OP_SAFE_C_SS: return(OP_SAFE_C_opSSq_C); } set_opt2_con(cdr(expr), caddr(expr)); @@ -68008,22 +68046,8 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb return(OP_SAFE_C_C_opSCq); case OP_SAFE_C_SS: - set_opt1_sym(cdr(expr), cadr(arg)); - if ((is_real(e1)) && - (symbol_id(car(arg)) == 0) && - (s7_d_pd_function(slot_value(global_slot(car(arg)))))) - { - s7_p_dd_t fp; - fp = s7_p_dd_function(func); - if (fp) - { - /* direct_c_c_opssq calls number_to_real on e1 */ - set_opt3_direct(cddr(expr), s7_d_pd_function(slot_value(global_slot(car(arg))))); - set_opt2_direct(cdr(expr), fp); - set_direct_opt(expr); - } - } - return(OP_SAFE_C_C_opSSq); + set_opt1_sym(cdr(expr), cadr(arg)); + return(OP_SAFE_C_C_opSSq); } return(OP_SAFE_C_CP); @@ -68034,22 +68058,7 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb { case OP_SAFE_C_S: if (is_safe_c_s(e1)) - { - s7_p_dd_t fp; - fp = s7_p_dd_function(func); - if (fp) - { - if ((symbol_id(car(e1)) == 0) && (s7_d_p_function(slot_value(global_slot(car(e1))))) && - (symbol_id(car(e2)) == 0) && (s7_d_p_function(slot_value(global_slot(car(e2)))))) - { - set_opt3_direct(cdr(expr), s7_d_p_function(slot_value(global_slot(car(e1))))); - set_opt3_direct(cddr(expr), s7_d_p_function(slot_value(global_slot(car(e2))))); - set_opt2_direct(cdr(expr), fp); - set_direct_opt(expr); - } - } - return(OP_SAFE_C_opSq_opSq); - } + return(OP_SAFE_C_opSq_opSq); if (optimize_op_match(e1, OP_SAFE_C_SS)) return(OP_SAFE_C_opSSq_opSq); break; @@ -68066,7 +68075,6 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb default: break; } - /* fprintf(stderr, "%s[%d]: unopt %s\n", __func__, __LINE__, DISPLAY(expr)); */ return(OP_UNOPT); } @@ -68117,7 +68125,7 @@ static opt_t wrap_bad_args(s7_scheme *sc, s7_pointer func, s7_pointer expr, int3 return(OPT_F); } if ((is_closure_star(func)) && - (lambda_has_simple_defaults(closure_body(func))) && + (lambda_has_simple_defaults(func)) && (closure_star_arity_to_int(sc, func) >= n_args) && (!arglist_has_rest(sc, closure_args(func)))) { @@ -68149,7 +68157,7 @@ static opt_t optimize_c_function_one_arg(s7_scheme *sc, s7_pointer expr, s7_poin { if (func_is_safe) /* safe c function */ { - set_safe_optimize_op(expr, hop + ((symbols == 0) ? OP_SAFE_C_D : (OP_SAFE_C_S))); + set_safe_optimize_op(expr, hop + ((symbols == 0) ? OP_SAFE_C_D : OP_SAFE_C_S)); choose_c_function(sc, expr, func, 1); return(OPT_T); } @@ -68177,20 +68185,12 @@ static opt_t optimize_c_function_one_arg(s7_scheme *sc, s7_pointer expr, s7_poin { int32_t op; op = combine_ops(sc, func, expr, E_C_P, arg1, NULL); - if ((hop == 1) && - (is_not_h_optimized(arg1))) - hop = 0; set_safe_optimize_op(expr, hop + op); - if ((!hop) && (is_h_optimized(arg1))) - clear_hop(arg1); - else + if ((op == OP_SAFE_C_P) && + (is_fxable(sc, arg1))) { - if ((op == OP_SAFE_C_P) && - (is_fxable(sc, arg1))) - { - set_optimize_op(expr, hop + OP_SAFE_C_A); - annotate_arg(sc, cdr(expr), e); - } + set_optimize_op(expr, hop + OP_SAFE_C_A); + annotate_arg(sc, cdr(expr), e); } choose_c_function(sc, expr, func, 1); return(OPT_T); @@ -68280,9 +68280,7 @@ static const char *pretty_print(s7_scheme *sc, s7_pointer obj) /* (pretty-print static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) { if (!is_pair(body)) return(false); - /* fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, DISPLAY(name), vars, DISPLAY(args), DISPLAY(body)); */ - - /* if (vars == 3) fprintf(stderr, "%s[%d] vars=3: %s\n", __func__, __LINE__, DISPLAY(body)); */ + /* fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, display(name), vars, display(args), display(body)); */ if (((vars == 1) || (vars == 2)) && ((car(body) == sc->and_symbol) || (car(body) == sc->or_symbol)) && @@ -68292,28 +68290,33 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar { s7_pointer orx; orx = caddr(body); - if ((is_proper_list_3(sc, orx)) && - ((car(orx) == sc->or_symbol) || (car(orx) == sc->and_symbol)) && + if (((car(orx) == sc->or_symbol) || (car(orx) == sc->and_symbol)) && (car(body) != car(orx)) && (is_fxable(sc, cadr(orx)))) { - s7_pointer tc; - tc = caddr(orx); - if ((is_pair(tc)) && - (car(tc) == name) && - (is_pair(cdr(tc))) && - (is_fxable(sc, cadr(tc))) && - (((vars == 1) && (is_null(cddr(tc)))) || - ((vars == 2) && (is_pair(cddr(tc))) && (is_null(cdddr(tc))) && (is_fxable(sc, caddr(tc)))))) - { - if (vars == 1) - set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_LA : OP_TC_OR_A_AND_A_LA); - else set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_LAA : OP_TC_OR_A_AND_A_LAA); - annotate_arg(sc, cdr(body), args); - annotate_arg(sc, cdr(orx), args); - annotate_args(sc, cdr(tc), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args)); - return(true); + s7_int len; + len = safe_list_length(orx); + if ((len == 3) || ((vars == 1) && (len == 4) && (tree_count(sc, name, orx, 0) == 1))) + { + s7_pointer tc; + tc = (len == 3) ? caddr(orx) : cadddr(orx); + if ((is_pair(tc)) && + (car(tc) == name) && + (is_pair(cdr(tc))) && + (is_fxable(sc, cadr(tc))) && + (((vars == 1) && (is_null(cddr(tc)))) || + ((vars == 2) && (is_pair(cddr(tc))) && (is_null(cdddr(tc))) && (is_fxable(sc, caddr(tc)))))) + { + if (vars == 1) + set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? ((len == 3) ? OP_TC_AND_A_OR_A_LA : OP_TC_AND_A_OR_A_A_LA) : OP_TC_OR_A_AND_A_LA); + else set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_LAA : OP_TC_OR_A_AND_A_LAA); + annotate_arg(sc, cdr(body), args); + annotate_arg(sc, cdr(orx), args); + if (len == 4) annotate_arg(sc, cddr(orx), args); + annotate_args(sc, cdr(tc), args); + fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args)); + return(true); + } } } else @@ -68350,6 +68353,7 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar } } } + if ((vars == 3) && (((car(body) == sc->or_symbol) && (is_proper_list_2(sc, cdr(body)))) || ((car(body) == sc->if_symbol) && (is_proper_list_3(sc, cdr(body))) && (caddr(body) == sc->T))) && @@ -68381,7 +68385,7 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar } } - if (((vars == 1) || (vars == 2)) && + if (((vars >= 1) && (vars <= 3)) && (car(body) == sc->if_symbol) && (safe_list_length(body) == 4)) /* (tree_count(sc, name, body, 0) == 1)) */ @@ -68445,8 +68449,7 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar set_optimized(body); return(true); } - return(false); - + return(false); } if ((is_proper_list_3(sc, true_p)) && (car(true_p) == name) && @@ -68466,20 +68469,55 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar } } + if (vars == 3) + { + if ((is_proper_list_4(sc, false_p)) && + (car(false_p) == name) && + (is_fxable(sc, cadr(false_p))) && (is_fxable(sc, caddr(false_p))) && (is_fxable(sc, cadddr(false_p)))) + { + set_optimize_op(body, OP_TC_IF_A_Z_L3A); + annotate_args(sc, cdr(false_p), args); + if (is_fxable(sc, true_p)) + { + annotate_arg(sc, cddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args)); + set_optimized(body); + return(true); + } + return(false); + } + if ((is_proper_list_4(sc, true_p)) && + (car(true_p) == name) && + (is_fxable(sc, cadr(true_p))) && (is_fxable(sc, caddr(true_p))) && (is_fxable(sc, cadddr(true_p)))) + { + set_optimize_op(body, OP_TC_IF_A_L3A_Z); + annotate_args(sc, cdr(true_p), args); + if (is_fxable(sc, false_p)) + { + annotate_arg(sc, cdddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args)); + set_optimized(body); + return(true); + } + return(false); + } + } + if ((is_proper_list_4(sc, false_p)) && (car(false_p) == sc->if_symbol)) { s7_pointer in_test, in_true, in_false; in_test = cadr(false_p); in_true = caddr(false_p); - in_false = cadddr(false_p); /* la */ + in_false = cadddr(false_p); + if (is_fxable(sc, in_test)) { s7_pointer la = NULL, z; if ((is_pair(in_false)) && (car(in_false) == name) && - (is_pair(cdr(in_false))) && - (is_fxable(sc, cadr(in_false)))) + (is_pair(cdr(in_false))) && + (is_fxable(sc, cadr(in_false)))) { la = in_false; z = cddr(false_p); @@ -68495,24 +68533,36 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar z = cdddr(false_p); } } - /* if ((la) && (s7_tree_memq(sc, name, car(z)))) fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, DISPLAY(name), DISPLAY(z)); */ - if ((la) && (!s7_tree_memq(sc, name, car(z)))) + if ((la) && ((vars == 3) || (!s7_tree_memq(sc, name, car(z))))) { if (((vars == 1) && (is_null(cddr(la)))) || - ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la))))) + ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la)))) || + ((vars == 3) && (is_proper_list_4(sc, in_true)) && (car(in_true) == name) && + (is_proper_list_4(sc, in_false)) && (is_fxable(sc, caddr(la))) && (is_fxable(sc, cadddr(la))) && + (is_fxable(sc, cadr(in_true))) && (is_fxable(sc, caddr(in_true))) && (is_fxable(sc, cadddr(in_true))))) { bool zs_fxable = true; if (vars == 1) set_optimize_op(body, (la == in_false) ? OP_TC_IF_A_Z_IF_A_Z_LA : OP_TC_IF_A_Z_IF_A_LA_Z); - else set_optimize_op(body, (la == in_false) ? OP_TC_IF_A_Z_IF_A_Z_LAA : OP_TC_IF_A_Z_IF_A_LAA_Z); + else + { + if (vars == 2) + set_optimize_op(body, (la == in_false) ? OP_TC_IF_A_Z_IF_A_Z_LAA : OP_TC_IF_A_Z_IF_A_LAA_Z); + else set_optimize_op(body, OP_TC_IF_A_Z_IF_A_L3A_L3A); + } if (is_fxable(sc, true_p)) /* outer (z) result */ annotate_arg(sc, cddr(body), args); else zs_fxable = false; annotate_arg(sc, cdr(false_p), args); /* inner test */ annotate_args(sc, cdr(la), args); /* la arg(s) */ - if (is_fxable(sc, car(z))) - annotate_arg(sc, z, args); /* inner (z) result */ - else zs_fxable = false; + if (vars == 3) + annotate_args(sc, cdr(in_true), args); + else + { + if (is_fxable(sc, car(z))) + annotate_arg(sc, z, args); /* inner (z) result */ + else zs_fxable = false; + } if ((has_fx(cddr(body))) && (has_fx(z))) fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args)); if (zs_fxable) set_optimized(body); @@ -68529,13 +68579,12 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar let_body = caddr(body); if ((vars == 2) && ((car(let_body) == sc->if_symbol) || (car(let_body) == sc->when_symbol) || (car(let_body) == sc->unless_symbol))) - /* (tree_count(sc, name, body, 0) == 1)) */ { s7_pointer test_expr; test_expr = cadr(let_body); if (is_fxable(sc, test_expr)) { - if (car(let_body) == sc->if_symbol) + if ((car(let_body) == sc->if_symbol) && (is_pair(cdddr(let_body)))) { s7_pointer laa; laa = cadddr(let_body); @@ -68675,33 +68724,39 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar else_clause = car(else_p); if ((is_proper_list_2(sc, else_clause)) && ((car(else_clause) == sc->else_symbol) || (car(else_clause) == sc->T)) && - (is_proper_list_3(sc, cadr(else_clause))) && + (is_pair(cadr(else_clause))) && (caadr(else_clause) == name) && - (is_fxable(sc, cadr(cadr(else_clause)))) && - (is_fxable(sc, caddr(cadr(else_clause))))) + (is_pair(cdadr(else_clause))) && (is_fxable(sc, cadr(cadr(else_clause)))) && + (((vars == 1) && (is_null(cddadr(else_clause)))) || + ((vars == 2) && (is_proper_list_3(sc, cadr(else_clause))) && (is_fxable(sc, caddadr(else_clause)))))) { bool zs_fxable = true; - if ((is_proper_list_3(sc, cadr(clause2))) && - (caadr(clause2) == name) && - (is_fxable(sc, cadr(cadr(clause2)))) && - (is_fxable(sc, caddr(cadr(clause2))))) + if (vars == 1) + set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LA); + else { - set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_LAA); - if (is_fxable(sc, cadr(clause1))) - annotate_args(sc, clause1, args); - else + if ((is_proper_list_3(sc, cadr(clause2))) && + (caadr(clause2) == name) && + (is_fxable(sc, cadr(cadr(clause2)))) && + (is_fxable(sc, caddadr(clause2)))) { - annotate_arg(sc, clause1, args); - zs_fxable = false; + set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_LAA); + if (is_fxable(sc, cadr(clause1))) + annotate_args(sc, clause1, args); + else + { + annotate_arg(sc, clause1, args); + zs_fxable = false; + } + annotate_arg(sc, clause2, args); + annotate_args(sc, cdadr(clause2), args); + annotate_args(sc, cdadr(else_clause), args); + fx_tree(sc, cdr(body), car(args), cadr(args)); + if (zs_fxable) set_optimized(body); + return(zs_fxable); } - annotate_arg(sc, clause2, args); - annotate_args(sc, cdadr(clause2), args); - annotate_args(sc, cdadr(else_clause), args); - fx_tree(sc, cdr(body), car(args), cadr(args)); - if (zs_fxable) set_optimized(body); - return(zs_fxable); + set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LAA); } - set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LAA); if (is_fxable(sc, cadr(clause1))) annotate_args(sc, clause1, args); else @@ -68717,7 +68772,7 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar zs_fxable = false; } annotate_args(sc, cdadr(else_clause), args); - fx_tree(sc, cdr(body), car(args), cadr(args)); + fx_tree(sc, cdr(body), car(args), (vars == 2) ? cadr(args) : NULL); if (zs_fxable) set_optimized(body); return(zs_fxable); } @@ -68794,14 +68849,10 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar if (results_fxable) set_optimized(body); return(results_fxable); } -#if 0 - if (tree_count(sc, name, body, 0) == 1) - fprintf(stderr, "%s[%d]: %s %d %s\n\n", __func__, __LINE__, DISPLAY(name), vars, DISPLAY(body)); -#endif return(false); } -static bool check_recur_if_one_or_two_vars(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) +static bool check_recur_if(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) { s7_pointer test; test = cadr(body); @@ -68914,11 +68965,20 @@ static bool check_recur_if_one_or_two_vars(s7_scheme *sc, s7_pointer name, int32 else { if ((vars == 2) && - (is_pair(cddr(la))) && - (is_fxable(sc, caddr(la))) && + (is_pair(cddr(la))) && (is_fxable(sc, caddr(la))) && (is_null(cdddr(la)))) set_safe_optimize_op(body, (orig == cadddr(body)) ? OP_RECUR_IF_A_A_opA_LAAq : OP_RECUR_IF_A_opA_LAAq_A); - else return(false); + else + { + /* fprintf(stderr, "%d: %s\n", __LINE__, display(body)); */ + if ((vars == 3) && + (is_pair(cddr(la))) && (is_fxable(sc, caddr(la))) && + (is_pair(cdddr(la))) && (is_fxable(sc, cadddr(la))) && + (is_null(cddddr(la))) && + (orig == cadddr(body))) + set_safe_optimize_op(body, OP_RECUR_IF_A_A_opA_L3Aq); + else return(false); + } } annotate_arg(sc, cdr(body), args); annotate_arg(sc, obody, args); @@ -68991,229 +69051,284 @@ static bool check_recur_if_one_or_two_vars(s7_scheme *sc, s7_pointer name, int32 set_opt3_pair(false_p, la3); return(true); }}}}} + + if ((vars == 3) && + (is_fxable(sc, test))) + { + s7_pointer true_p, false_p; + true_p = caddr(body); + false_p = cadddr(body); + if ((is_fxable(sc, true_p)) && + (is_proper_list_4(sc, false_p)) && + (car(false_p) == name)) + { + s7_pointer l3a, la1, la2, la3; + l3a = cdr(false_p); + la1 = car(l3a); + la2 = cadr(l3a); + la3 = caddr(l3a); + if ((is_proper_list_4(sc, la1)) && (is_proper_list_4(sc, la2)) && (is_proper_list_4(sc, la3)) && + (car(la1) == name) && (car(la2) == name) && (car(la3) == name) && + (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) && (is_fxable(sc, cadr(la3))) && + (is_fxable(sc, caddr(la1))) && (is_fxable(sc, caddr(la2))) && (is_fxable(sc, caddr(la3))) && + (is_fxable(sc, cadddr(la1))) && (is_fxable(sc, cadddr(la2))) && (is_fxable(sc, cadddr(la3)))) + { + set_safe_optimize_op(body, OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq); + annotate_args(sc, cdr(la1), args); + annotate_args(sc, cdr(la2), args); + annotate_args(sc, cdr(la3), args); + annotate_arg(sc, cdr(body), args); + annotate_arg(sc, cddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args)); + set_opt3_pair(body, false_p); + set_opt3_pair(false_p, la3); + return(true); + }}} return(false); } static bool check_recur(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) { - /* fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, DISPLAY(name), vars, DISPLAY(args), DISPLAY(body)); */ + /* fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, display(name), vars, display(args), display(body)); */ if ((car(body) == sc->if_symbol) && (safe_list_length(body) == 4)) + return(check_recur_if(sc, name, vars, args, body)); + + if (car(body) == sc->cond_symbol) { - if ((vars == 1) || (vars == 2)) - return(check_recur_if_one_or_two_vars(sc, name, vars, args, body)); - if (vars == 3) + s7_pointer clause, clause2 = NULL; + clause = cadr(body); + if ((is_proper_list_1(sc, (cdr(clause)))) && + (is_fxable(sc, car(clause))) && + (is_fxable(sc, cadr(clause)))) { - s7_pointer test; - test = cadr(body); - if (is_fxable(sc, test)) + s7_pointer la_clause; + s7_int len; + len = safe_list_length(body); + la_clause = caddr(body); + if (len == 4) { - s7_pointer true_p, false_p; - true_p = caddr(body); - false_p = cadddr(body); - if ((is_fxable(sc, true_p)) && - (is_proper_list_4(sc, false_p)) && - (car(false_p) == name)) + if ((is_proper_list_2(sc, la_clause)) && + (is_fxable(sc, car(la_clause)))) { - s7_pointer l3a, la1, la2, la3; - l3a = cdr(false_p); - la1 = car(l3a); - la2 = cadr(l3a); - la3 = caddr(l3a); - if ((is_proper_list_4(sc, la1)) && (is_proper_list_4(sc, la2)) && (is_proper_list_4(sc, la3)) && - (car(la1) == name) && (car(la2) == name) && (car(la3) == name) && - (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) && (is_fxable(sc, cadr(la3))) && - (is_fxable(sc, caddr(la1))) && (is_fxable(sc, caddr(la2))) && (is_fxable(sc, caddr(la3))) && - (is_fxable(sc, cadddr(la1))) && (is_fxable(sc, cadddr(la2))) && (is_fxable(sc, cadddr(la3)))) - { - set_safe_optimize_op(body, OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq); - annotate_args(sc, cdr(la1), args); - annotate_args(sc, cdr(la2), args); - annotate_args(sc, cdr(la3), args); - annotate_arg(sc, cdr(body), args); - annotate_arg(sc, cddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args)); - set_opt3_pair(body, false_p); - set_opt3_pair(false_p, la3); - return(true); - } + clause2 = la_clause; + la_clause = cadddr(body); } + else return(false); } - } - } - else - { - if (car(body) == sc->cond_symbol) - { - s7_pointer clause, clause2 = NULL; - clause = cadr(body); - if ((is_proper_list_1(sc, (cdr(clause)))) && - (is_fxable(sc, car(clause))) && - (is_fxable(sc, cadr(clause)))) + if ((is_proper_list_2(sc, la_clause)) && + ((car(la_clause) == sc->else_symbol) || (car(la_clause) == sc->T)) && + (is_pair(cadr(la_clause)))) { - s7_pointer la_clause; - s7_int len; - len = safe_list_length(body); - la_clause = caddr(body); - if (len == 4) - { - if ((is_proper_list_2(sc, la_clause)) && - (is_fxable(sc, car(la_clause)))) - { - clause2 = la_clause; - la_clause = cadddr(body); - } - else - { - /* if (!(sc->got_tc)) fprintf(stderr, "%s[%d]: %s %s\n%s\n\n", __func__, __LINE__, DISPLAY(name), DISPLAY(args), DISPLAY(body)); */ - return(false); - } - } - if ((is_proper_list_2(sc, la_clause)) && - ((car(la_clause) == sc->else_symbol) || (car(la_clause) == sc->T)) && - (is_pair(cadr(la_clause)))) + la_clause = cadr(la_clause); /* (c_op arg (recur par)) or (c_op (recur) (recur)) or (op|l a laa) */ + if (is_proper_list_2(sc, cdr(la_clause))) { - la_clause = cadr(la_clause); /* (c_op arg (recur par)) or (c_op (recur) (recur)) or (op|l a laa) */ - if (is_proper_list_2(sc, cdr(la_clause))) + if (is_h_optimized(la_clause)) { - if (is_h_optimized(la_clause)) + if ((is_fxable(sc, cadr(la_clause))) && + ((len == 3) || + ((len == 4) && (vars == 2) && + (is_proper_list_3(sc, cadr(clause2))) && + (caadr(clause2) == name)))) { - if ((is_fxable(sc, cadr(la_clause))) && - ((len == 3) || - ((len == 4) && (vars == 2) && - (is_proper_list_3(sc, cadr(clause2))) && - (caadr(clause2) == name)))) + s7_pointer la; + la = caddr(la_clause); + if ((is_pair(la)) && + (car(la) == name) && + (is_pair(cdr(la))) && + (is_fxable(sc, cadr(la))) && + (((vars == 1) && (is_null(cddr(la)))) || + ((vars == 2) && + (is_pair(cddr(la))) && + (is_fxable(sc, caddr(la))) && + (is_null(cdddr(la)))))) { - s7_pointer la; - la = caddr(la_clause); - if ((is_pair(la)) && - (car(la) == name) && - (is_pair(cdr(la))) && - (is_fxable(sc, cadr(la))) && - (((vars == 1) && (is_null(cddr(la)))) || - ((vars == 2) && - (is_pair(cddr(la))) && - (is_fxable(sc, caddr(la))) && - (is_null(cdddr(la)))))) + if (len == 3) + set_safe_optimize_op(body, (vars == 1) ? OP_RECUR_COND_A_A_opA_LAq : OP_RECUR_COND_A_A_opA_LAAq); + else { - if (len == 3) - set_safe_optimize_op(body, (vars == 1) ? OP_RECUR_COND_A_A_opA_LAq : OP_RECUR_COND_A_A_opA_LAAq); - else + s7_pointer laa; + laa = cadr(clause2); + if ((is_fxable(sc, cadr(laa))) && /* args to first laa */ + (is_fxable(sc, caddr(laa)))) { - s7_pointer laa; - laa = cadr(clause2); - if ((is_fxable(sc, cadr(laa))) && /* args to first laa */ - (is_fxable(sc, caddr(laa)))) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_LAA_opA_LAAq); - annotate_arg(sc, clause2, args); - annotate_args(sc, cdr(laa), args); - } - else return(false); + set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_LAA_opA_LAAq); + annotate_arg(sc, clause2, args); + annotate_args(sc, cdr(laa), args); } - annotate_args(sc, clause, args); - annotate_arg(sc, cdr(la_clause), args); - annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args)); - set_opt3_pair(body, la_clause); - set_opt3_pair(la_clause, la); - return(true); + else return(false); } + annotate_args(sc, clause, args); + annotate_arg(sc, cdr(la_clause), args); + annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args)); + set_opt3_pair(body, la_clause); + set_opt3_pair(la_clause, la); + return(true); } - else + } + else + { + if (len == 4) { - if (len == 4) + s7_pointer la1, la2; + bool happy = false; + la1 = cadr(la_clause); + la2 = caddr(la_clause); + + if ((vars == 1) && + (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2)) && + (car(la1) == name) && (car(la2) == name) && + (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2)))) { - s7_pointer la1, la2; - bool happy = false; - la1 = cadr(la_clause); - la2 = caddr(la_clause); - - if ((vars == 1) && - (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2)) && - (car(la1) == name) && (car(la2) == name) && - (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2)))) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opLA_LAq); - annotate_arg(sc, cdr(la1), args); - happy = true; - } - else + set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opLA_LAq); + annotate_arg(sc, cdr(la1), args); + happy = true; + } + else + { + if ((vars == 2) && + (is_fxable(sc, cadr(clause2))) && + (is_proper_list_3(sc, la2)) && + (car(la2) == name) && + (is_fxable(sc, cadr(la2))) && + (is_fxable(sc, caddr(la2)))) { - if ((vars == 2) && - (is_fxable(sc, cadr(clause2))) && - (is_proper_list_3(sc, la2)) && - (car(la2) == name) && - (is_fxable(sc, cadr(la2))) && - (is_fxable(sc, caddr(la2)))) + if (is_fxable(sc, la1)) + { + set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opA_LAAq); + annotate_arg(sc, cdr(la_clause), args); + happy = true; + } + else { - if (is_fxable(sc, la1)) + if ((is_proper_list_3(sc, la1)) && + (car(la1) == name) && + (is_fxable(sc, cadr(la1))) && + (is_fxable(sc, caddr(la1)))) { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opA_LAAq); - annotate_arg(sc, cdr(la_clause), args); + set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opLAA_LAAq); + annotate_args(sc, cdr(la1), args); happy = true; } - else - { - if ((is_proper_list_3(sc, la1)) && - (car(la1) == name) && - (is_fxable(sc, cadr(la1))) && - (is_fxable(sc, caddr(la1)))) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opLAA_LAAq); - annotate_args(sc, cdr(la1), args); - happy = true; - } - } } } - if (happy) - { - set_opt3_pair(la_clause, cdr(la2)); - annotate_args(sc, clause, args); - annotate_args(sc, clause2, args); - annotate_args(sc, cdr(la2), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args)); - set_opt3_pair(body, la_clause); - return(true); - } + } + if (happy) + { + set_opt3_pair(la_clause, cdr(la2)); + annotate_args(sc, clause, args); + annotate_args(sc, clause2, args); + annotate_args(sc, cdr(la2), args); + fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args)); + set_opt3_pair(body, la_clause); + return(true); } } } - else + } + else + { + if (clause2) { - if (clause2) + s7_pointer laa; + laa = cadr(clause2); + + if ((vars == 2) && (len == 4) && + (is_proper_list_3(sc, laa)) && + (car(laa) == name) && + (is_fxable(sc, cadr(laa))) && + (is_fxable(sc, caddr(laa)))) { - s7_pointer laa; - laa = cadr(clause2); - - if ((vars == 2) && (len == 4) && - (is_proper_list_3(sc, laa)) && - (car(laa) == name) && - (is_fxable(sc, cadr(laa))) && - (is_fxable(sc, caddr(laa)))) + s7_pointer la1, la2; + la1 = cadr(la_clause); + la2 = caddr(la_clause); + if ((is_fxable(sc, la1)) && + (is_proper_list_3(sc, la2)) && + (car(la2) == name) && + (is_fxable(sc, cadr(la2))) && + (is_fxable(sc, caddr(la2)))) { - s7_pointer la1, la2; - la1 = cadr(la_clause); - la2 = caddr(la_clause); - if ((is_fxable(sc, la1)) && - (is_proper_list_3(sc, la2)) && - (car(la2) == name) && - (is_fxable(sc, cadr(la2))) && - (is_fxable(sc, caddr(la2)))) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_LAA_LopA_LAAq); - annotate_args(sc, clause, args); - annotate_arg(sc, clause2, args); - annotate_args(sc, cdr(laa), args); - annotate_arg(sc, cdr(la_clause), args); - annotate_args(sc, cdr(la2), args); - fx_tree(sc, cdr(body), car(args), cadr(args)); - set_opt3_pair(body, la_clause); - set_opt3_pair(la_clause, cdr(la2)); - return(true); - }}}}}}}}} + set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_LAA_LopA_LAAq); + annotate_args(sc, clause, args); + annotate_arg(sc, clause2, args); + annotate_args(sc, cdr(laa), args); + annotate_arg(sc, cdr(la_clause), args); + annotate_args(sc, cdr(la2), args); + fx_tree(sc, cdr(body), car(args), cadr(args)); + set_opt3_pair(body, la_clause); + set_opt3_pair(la_clause, cdr(la2)); + return(true); + }}}}}}}} + return(false); +} + +static opt_t fxify_safe_closure_s(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, bool sym, int32_t hop) +{ + s7_pointer body; + /* fprintf(stderr, "%s: %s %d\n", __func__, display(expr), hop); */ + + body = closure_body(func); + annotate_arg(sc, body, e); + if (sym) + { + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_A); + if ((is_pair(car(body))) && (is_pair(cdar(body))) && (car(closure_args(func)) == cadar(body))) + { + if (optimize_op(car(body)) == HOP_SAFE_C_S) + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_S); + else + { + if (optimize_op(car(body)) == HOP_SAFE_C_SC) + { + s7_pointer body_arg2; + body_arg2 = caddar(body); + set_opt3_any(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_SC); + } + } + } + } + else set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_C_A); + set_closure_has_fx(func); + fx_tree(sc, body, car(closure_args(func)), NULL); + return(OPT_T); +} + +static bool fxify_closure_a(s7_scheme *sc, s7_pointer func, bool one_form, bool safe_case, int32_t hop, s7_pointer expr, s7_pointer e) +{ + if (one_form) + { + if (safe_case) + { + s7_pointer body; + body = closure_body(func); + if (is_fxable(sc, car(body))) + { + annotate_arg(sc, body, e); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_A); + + if (is_pair(car(body))) + { + if ((optimize_op(car(body)) == HOP_SAFE_C_SC) && (car(closure_args(func)) == cadar(body))) + { + s7_pointer body_arg2; + body_arg2 = caddar(body); + set_opt3_any(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_TO_SC); + } + } + + set_closure_has_fx(func); + fx_tree(sc, body, car(closure_args(func)), NULL); + return(true); + } + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_P); + } + else set_optimize_op(expr, hop + OP_CLOSURE_A_P); + } + else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_A : OP_CLOSURE_A)); return(false); } @@ -69253,33 +69368,7 @@ static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer if (safe_case) { if (is_fxable(sc, car(body))) - { - annotate_arg(sc, body, e); - if (sym) - { - if (((optimize_op(car(body)) == HOP_SAFE_C_S) || (optimize_op(car(body)) == HOP_SAFE_C_SC)) && - (car(closure_args(func)) == cadar(body))) - { - if (optimize_op(car(body)) == HOP_SAFE_C_S) - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_S); - else - { - set_opt3_any(cdr(expr), caddar(body)); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_SC); - } - } - else - { - if (car(closure_args(func)) == car(body)) - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_ID_S); - else set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_A); - } - } - else set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_C_A); - set_closure_has_fx(func); - fx_tree(sc, body, car(closure_args(func)), NULL); - return(OPT_T); - } + return(fxify_safe_closure_s(sc, func, expr, e, sym, hop)); set_optimize_op(expr, hop + ((sym) ? OP_SAFE_CLOSURE_S_P : OP_SAFE_CLOSURE_C_P)); } else set_optimize_op(expr, hop + ((sym) ? OP_CLOSURE_S_P : OP_CLOSURE_C_P)); @@ -69289,30 +69378,14 @@ static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer return(OPT_F); } + /* fprintf(stderr, "expr: %s, fx: %d, op: %s\n", display(expr), is_fxable(sc, cadr(expr)), op_names[optimize_op(cadr(expr))]); */ if (fx_count(sc, expr) == 1) { set_unsafely_optimized(expr); set_opt1_lambda(expr, func); annotate_arg(sc, cdr(expr), e); set_opt3_arglen(expr, small_int(1)); - - if (one_form) - { - if (safe_case) - { - if (is_fxable(sc, car(body))) - { - annotate_arg(sc, body, e); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_A); - set_closure_has_fx(func); - fx_tree(sc, body, car(closure_args(func)), NULL); - return(OPT_T); - } - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_P); - } - else set_optimize_op(expr, hop + OP_CLOSURE_A_P); - } - else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_A : OP_CLOSURE_A)); + if (fxify_closure_a(sc, func, one_form, safe_case, hop, expr, e)) return(OPT_T); set_unsafely_optimized(expr); return(OPT_F); } @@ -69328,7 +69401,7 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu s7_pointer arg1; /* very often, expr is already optimized, quoted stuff is counted under "bad_pairs"! as well as quotes */ #if OPTIMIZE_PRINT - fprintf(stderr, "%s expr: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad: %d\n", __func__, DISPLAY_80(expr), DISPLAY(func), hop, pairs, symbols, quotes, bad_pairs); + fprintf(stderr, "%s expr: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad: %d\n", __func__, display_80(expr), display(func), hop, pairs, symbols, quotes, bad_pairs); #endif if (quotes > 0) { @@ -69376,16 +69449,22 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu set_opt1_lambda(expr, func); set_opt3_arglen(expr, small_int(1)); set_unsafely_optimized(expr); - if (lambda_has_simple_defaults(closure_body(func))) - { - if (arglist_has_rest(sc, closure_args(func))) - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_FX_1 : OP_CLOSURE_STAR_FX)); - else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)); - } + + if ((safe_case) && (is_null(cdr(closure_args(func))))) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_A1); /* TODO: unknown cases + fxify */ else { - if (safe_case) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_FX_1); + if (lambda_has_simple_defaults(func)) + { + if (arglist_has_rest(sc, closure_args(func))) + set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_FX_1 : OP_CLOSURE_STAR_FX)); + else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)); + } + else + { + if (safe_case) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_FX_1); + } } return(OPT_F); } @@ -69441,7 +69520,7 @@ static inline s7_pointer find_uncomplicated_symbol(s7_scheme *sc, s7_pointer sym s7_pointer x; int64_t id; #if OPTIMIZE_PRINT - fprintf(stderr, " find %s in %s (in list: %d)\n", DISPLAY(symbol), DISPLAY(e), symbol_is_in_list(sc, symbol)); + fprintf(stderr, " find %s in %s (in list: %d)\n", display(symbol), display(e), symbol_is_in_list(sc, symbol)); #endif if ((symbol_is_in_list(sc, symbol)) && (let_memq(symbol, e))) /* it's probably a local variable reference */ @@ -69524,7 +69603,7 @@ static bool safe_c_aa_to_ca(s7_scheme *sc, s7_pointer arg, int hop) { if (c_callee(cddr(arg)) == fx_c) {set_opt3_any(arg, caddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} if (c_callee(cdr(arg)) == fx_c) {set_opt3_any(arg, cadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);} - if (c_callee(cddr(arg)) == fx_q) {set_opt3_any(arg, cadr(caddr(arg))); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} + if (c_callee(cddr(arg)) == fx_q) {set_opt3_any(arg, cadaddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} if (c_callee(cdr(arg)) == fx_q) {set_opt3_any(arg, cadadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);} return(false); } @@ -69535,7 +69614,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f { s7_pointer arg1, arg2; #if OPTIMIZE_PRINT - fprintf(stderr, "%s %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad: %d\n", __func__, DISPLAY_80(expr), hop, pairs, symbols, quotes, bad_pairs); + fprintf(stderr, "%s %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad: %d\n", __func__, display_80(expr), hop, pairs, symbols, quotes, bad_pairs); #endif if (quotes > 0) { @@ -69675,45 +69754,34 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f { int32_t op; op = combine_ops(sc, func, expr, E_C_PP, arg1, arg2); - if ((hop == 1) && - ((is_not_h_optimized(arg1)) || (is_not_h_optimized(arg2)))) - hop = 0; set_safe_optimize_op(expr, hop + op); if (op == OP_SAFE_C_PP) opt_sp_1(sc, c_function_call(func), expr); /* calls set_opt1_any, sets opt1(cdr(expr)) to OP_SAFE_CONS_SP_1 and friends */ - if (!hop) - { - if (is_h_optimized(arg1)) clear_hop(arg1); - if (is_h_optimized(arg2)) clear_hop(arg2); - } - else + if (op == OP_SAFE_C_PP) { - if (op == OP_SAFE_C_PP) + if (is_fxable(sc, arg1)) { - if (is_fxable(sc, arg1)) + if (is_fxable(sc, arg2)) { - if (is_fxable(sc, arg2)) - { - set_optimize_op(expr, hop + OP_SAFE_C_AA); - annotate_args(sc, cdr(expr), e); - if (!safe_c_aa_to_ca(sc, expr, hop)) - set_opt3_arglen(expr, small_int(2)); - } - else - { - set_optimize_op(expr, hop + OP_SAFE_C_AP); - annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(expr, small_int(2)); - } + set_optimize_op(expr, hop + OP_SAFE_C_AA); + annotate_args(sc, cdr(expr), e); + if (!safe_c_aa_to_ca(sc, expr, hop)) + set_opt3_arglen(expr, small_int(2)); } else { - if (is_fxable(sc, arg2)) - { - set_optimize_op(expr, hop + OP_SAFE_C_PA); - annotate_arg(sc, cddr(expr), e); - set_opt3_arglen(expr, small_int(2)); - } + set_optimize_op(expr, hop + OP_SAFE_C_AP); + annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(expr, small_int(2)); + } + } + else + { + if (is_fxable(sc, arg2)) + { + set_optimize_op(expr, hop + OP_SAFE_C_PA); + annotate_arg(sc, cddr(expr), e); + set_opt3_arglen(expr, small_int(2)); } } } @@ -69737,7 +69805,6 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f orig_op = E_C_PS; else orig_op = E_C_PC; op = combine_ops(sc, func, expr, orig_op, arg1, arg2); - if ((!hop) && (is_h_optimized(arg1))) clear_hop(arg1); } else { @@ -69745,12 +69812,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f orig_op = E_C_SP; else orig_op = E_C_CP; op = combine_ops(sc, func, expr, orig_op, arg1, arg2); - if ((!hop) && (is_h_optimized(arg2))) clear_hop(arg2); } - if ((hop == 1) && - ((is_not_h_optimized(arg1)) || (is_not_h_optimized(arg2)))) - hop = 0; - if ((((op == OP_SAFE_C_SP) || (op == OP_SAFE_C_CP)) && (is_fxable(sc, arg2))) || (((op == OP_SAFE_C_PS) || (op == OP_SAFE_C_PC)) && @@ -69881,6 +69943,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f set_optimized(expr); if (is_normal_symbol(arg1)) { + /* fprintf(stderr, "%d: %d\n", __LINE__, hop); */ set_optimize_op(expr, hop + OP_SAFE_C_SP); opt_sp_1(sc, c_function_call(func), expr); choose_c_function(sc, expr, func, 2); @@ -70227,9 +70290,12 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f } if (is_safe_closure(func)) - return(set_safe_closure_fp(sc, func, expr, e, 2, hop + OP_SAFE_CLOSURE_FP)); - - return((is_optimized(expr)) ? OPT_T : OPT_F); + return(set_safe_closure_fp(sc, func, expr, e, 2, hop + OP_SAFE_CLOSURE_PP)); + + set_unsafely_optimized(expr); + set_optimize_op(expr, hop + OP_CLOSURE_PP); + set_opt1_lambda(expr, func); + return(OPT_F); } if (is_closure_star(func)) @@ -70237,17 +70303,31 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f if (is_immutable(func)) hop = 1; if (fx_count(sc, expr) == 2) { + int32_t arity; + bool safe_case; + s7_pointer par1; + + safe_case = is_safe_closure(func); + arity = closure_star_arity_to_int(sc, func); set_unsafely_optimized(expr); - if (lambda_has_simple_defaults(closure_body(func))) - { - if (closure_star_arity_to_int(sc, func) == 2) - set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_AA : OP_CLOSURE_STAR_FX)); - else set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_FX_2 : OP_CLOSURE_STAR_FX)); - } + par1 = car(closure_args(func)); + if (is_pair(par1)) par1 = car(par1); + + if ((arity == 1) && (is_keyword(arg1)) && (keyword_symbol(arg1) == par1)) + set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_KA : OP_CLOSURE_STAR_KA)); else { - if (is_safe_closure(func)) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_FX_2); + if (lambda_has_simple_defaults(func)) + { + if (arity == 2) /* safe_closure_star_aa_a here is actually slower (overhead > eval reduction) */ + set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_AA : OP_CLOSURE_STAR_FX)); + else set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_FX_2 : OP_CLOSURE_STAR_FX)); + } + else + { + if (is_safe_closure(func)) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_FX_2); + } } annotate_args(sc, cdr(expr), e); set_opt1_lambda(expr, func); @@ -70284,6 +70364,12 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f static opt_t set_safe_c_fp(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, int32_t num_args, opcode_t op) { s7_pointer p; + /* fprintf(stderr, "%s\n", display(expr)); */ + /* odd: (list-values '+ (sqrt 9) 4), (list (if (memq op2 gtes) op1 op2) x c1), (list (cadr (assq op1 relops)) c1 x c2), (+ (round pi) 1 1 1 1) + * if_opssq_aa + * why missed fx_safe_closure_s_a? -- op_* + * if op_safe_closure* check for func and call else goto eval? similarly for op_safe_c* + */ for (p = cdr(expr); is_pair(p); p = cdr(p)) set_c_call_checked(p, fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe)); set_opt3_arglen(expr, make_permanent_integer(num_args)); @@ -70296,7 +70382,7 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer { s7_pointer arg1, arg2, arg3; #if OPTIMIZE_PRINT - fprintf(stderr, "%s: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad: %d\n", __func__, DISPLAY_80(expr), DISPLAY(func), hop, pairs, symbols, quotes, bad_pairs); + fprintf(stderr, "%s: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad: %d\n", __func__, display_80(expr), display(func), hop, pairs, symbols, quotes, bad_pairs); #endif if ((quotes > 0) && @@ -70338,7 +70424,7 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer return(OPT_F); } if ((is_closure_star(func)) && - (lambda_has_simple_defaults(closure_body(func))) && + (lambda_has_simple_defaults(func)) && (closure_star_arity_to_int(sc, func) != 0) && (closure_star_arity_to_int(sc, func) != 1)) { @@ -70501,7 +70587,6 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer if ((hop == 1) && (s7_p_ppp_function(func))) { set_optimize_op(expr, OP_SSA_DIRECT); - set_direct_opt(expr); set_opt2_direct(cdr(expr), (s7_pointer)(s7_p_ppp_function(func))); } else set_optimize_op(expr, hop + OP_SAFE_C_SSA); @@ -70637,14 +70722,32 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer if (symbols == 3) { + s7_pointer body; + body = closure_body(func); set_opt1_lambda(expr, func); set_opt3_arglen(expr, small_int(3)); - set_unsafe_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_3S : ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_3S_P : OP_CLOSURE_3S))); + + if (is_safe_closure(func)) + { + if ((is_null(cdr(body))) && + (is_fxable(sc, car(body)))) + { + set_opt2_sym(expr, arg2); + set_opt3_sym(expr, arg3); + annotate_arg(sc, body, e); + fx_tree(sc, body, car(closure_args(func)), cadr(closure_args(func))); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S_A); + set_closure_has_fx(func); + } + else set_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S); + return(OPT_T); + } + else set_unsafe_optimize_op(expr, hop + ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_3S_P : OP_CLOSURE_3S)); return(OPT_F); } #if OPTIMIZE_PRINT - fprintf(stderr, " closure fx_count: %d, safe: %d\n", fx_count(sc, expr), is_safe_closure(func)); + fprintf(stderr, " %s closure fx_count: %d, safe: %d\n", display_80(expr), fx_count(sc, expr), is_safe_closure(func)); #endif if (fx_count(sc, expr) == 3) @@ -70658,15 +70761,12 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer set_opt3_arglen(expr, small_int(3)); return(OPT_F); } - if (is_safe_closure(func)) - return(set_safe_closure_fp(sc, func, expr, e, 3, hop + OP_SAFE_CLOSURE_FP)); - /* unsafe_closure_fp got few hits and made no difference */ - return(OPT_F); + return(set_safe_closure_fp(sc, func, expr, e, 3, hop + OP_SAFE_OR_UNSAFE_CLOSURE_3P)); } if (is_closure_star(func)) { - if ((!lambda_has_simple_defaults(closure_body(func))) || + if ((!lambda_has_simple_defaults(func)) || (closure_star_arity_to_int(sc, func) == 0) || (closure_star_arity_to_int(sc, func) == 1)) return(OPT_F); @@ -70712,7 +70812,7 @@ static bool symbols_are_safe(s7_scheme *sc, s7_pointer args, s7_pointer e) static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) { bool func_is_closure; - /* fprintf(stderr, "%s[%d]: %s, args: %d, bad: %d, quotes: %d\n", __func__, __LINE__, DISPLAY_80(expr), args, bad_pairs, quotes); */ + /* fprintf(stderr, "%s[%d]: %s, args: %d, bad: %d, quotes: %d\n", __func__, __LINE__, display_80(expr), args, bad_pairs, quotes); */ if (quotes > 0) { @@ -70829,15 +70929,6 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer annotate_args(sc, cdr(expr), e); set_opt3_arglen(expr, make_permanent_integer(args)); set_opt1_lambda(expr, func); -#if 0 - if ((s7_is_equal(sc, closure_args(func), cdar(closure_body(func)))) && - (is_null(cdr(closure_body(func))))) - fprintf(stderr, "same: %s %s\n", DISPLAY(closure_args(func)), DISPLAY(closure_body(func))); - /* this actually happens: closure_s_to_s in 1-arg case? - * perhaps 2/3 arg cases too? - * closure_id_any? - */ -#endif if ((symbols == args) && (symbols_are_safe(sc, cdr(expr), e))) @@ -70855,7 +70946,7 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer } if ((is_closure_star(func)) && - ((!lambda_has_simple_defaults(closure_body(func))) || + ((!lambda_has_simple_defaults(func)) || (closure_star_arity_to_int(sc, func) == 0) || (closure_star_arity_to_int(sc, func) == 1))) return(OPT_F); @@ -70928,10 +71019,17 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in s7_pointer p, body, vars; bool body_export_ok = true; #if OPTIMIZE_PRINT - fprintf(stderr, "optimize_syntax %s %d %s\n", DISPLAY(expr), hop, DISPLAY(e)); + fprintf(stderr, "optimize_syntax %s %d %s\n", display(expr), hop, display(e)); #endif op = (opcode_t)syntax_opcode(func); +#if 0 + fprintf(stderr, "op: %s\n", op_names[op]); + if ((is_slot(global_slot(car(expr)))) && (op != (opcode_t)symbol_syntax_op_checked(expr))) + fprintf(stderr, "%s != %s\n", op_names[op], op_names[(opcode_t)symbol_syntax_op_checked(expr)]); +#endif + /* pair_set_syntax_op(expr, op); */ /* much slower?? */ + sc->w = e; body = cdr(expr); @@ -71407,9 +71505,17 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in } else { + if ((c_callee(test) == fx_and_2) && (c_callee(b1) == fx_s)) + { + set_opt1_pair(expr, cdadr(expr)); + set_opt2_pair(expr, cddadr(expr)); + set_opt3_sym(expr, car(b1)); + set_safe_optimize_op(expr, OP_IF_AND2_SA); + return(OPT_T); + } set_opt1_pair(expr, b1); if (is_pair(b2)) set_opt2_pair(expr, b2); - set_safe_optimize_op(expr, (is_null(b2)) ? OP_IF_A_A : OP_IF_A_AA); + set_safe_optimize_op(expr, (is_null(b2)) ? OP_IF_A_A : ((c_callee(test) == fx_s) ? OP_IF_S_AA : OP_IF_A_AA)); } } } @@ -71427,7 +71533,7 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 { s7_pointer car_expr; #if OPTIMIZE_PRINT - fprintf(stderr, "optimize_expression %s %d %s\n", DISPLAY(expr), hop, DISPLAY(e)); + fprintf(stderr, "optimize_expression %s %d %s\n", display(expr), hop, display(e)); #endif set_checked(expr); car_expr = car(expr); @@ -71444,7 +71550,7 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 slot = find_uncomplicated_symbol(sc, car_expr, e); /* local vars (recursive calls too??) are considered "complicated" */ #if OPTIMIZE_PRINT - if (!is_slot(slot)) fprintf(stderr, " %s is not simple\n", DISPLAY(expr)); + if (!is_slot(slot)) fprintf(stderr, " %s is not simple\n", display(expr)); #endif if (is_slot(slot)) { @@ -71564,13 +71670,13 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 (port_file(p) != stdin) && (!port_is_closed(p)) && (port_filename(p))) - s7_warn(sc, 1024, "%s might be undefined (%s %u)\n", DISPLAY(car_expr), port_filename(p), port_line_number(p)); - else s7_warn(sc, 1024, "; %s might be undefined\n", DISPLAY(car_expr)); + s7_warn(sc, 1024, "%s might be undefined (%s %u)\n", display(car_expr), port_filename(p), port_line_number(p)); + else s7_warn(sc, 1024, "; %s might be undefined\n", display(car_expr)); symbol_set_tag(car_expr, 1); /* one warning is enough */ } } #if OPTIMIZE_PRINT - fprintf(stderr, " at line %d for %s\n", __LINE__, DISPLAY(car_expr)); + fprintf(stderr, " at line %d for %s\n", __LINE__, display(car_expr)); #endif /* car_expr is a symbol but it's not a built-in procedure or a "safe" case = vector etc */ { @@ -71746,7 +71852,7 @@ static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e) { s7_pointer x; #if OPTIMIZE_PRINT - fprintf(stderr, "optimize: %s %s\n", DISPLAY_80(code), DISPLAY(e)); + fprintf(stderr, "optimize: %s %s\n", display_80(code), display(e)); #endif for (x = code; (is_pair(x)) && (!is_checked(x)); x = cdr(x)) { @@ -71950,10 +72056,10 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at s7_pointer expr; body_t result = VERY_SAFE_BODY; #if S7_DEBUGGING - if (!is_pair(x)) {fprintf(stderr, "form_is_safe x is not a pair! %s\n", DISPLAY(x)); abort();} + if (!is_pair(x)) {fprintf(stderr, "form_is_safe x is not a pair! %s\n", display(x)); abort();} #endif #if OPTIMIZE_PRINT - fprintf(stderr, "%s[%d]: %s %s %d\n", __func__, __LINE__, DISPLAY(func), DISPLAY(x), at_end); + fprintf(stderr, "%s[%d]: %s %s %d\n", __func__, __LINE__, display(func), display(x), at_end); #endif expr = car(x); if (is_syntactic_symbol(expr)) @@ -72369,7 +72475,7 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at } } #if OPTIMIZE_PRINT - fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, DISPLAY(x)); + fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(x)); #endif return_unsafe_body(sc); } @@ -72381,7 +72487,7 @@ static body_t body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer body, bool bool follow = false; s7_pointer p, sp; body_t result = VERY_SAFE_BODY; - /* fprintf(stderr, "%s: %s %s %d\n", __func__, DISPLAY(func), DISPLAY(body), at_end); */ + /* fprintf(stderr, "%s: %s %s %d\n", __func__, display(func), display(body), at_end); */ for (p = body, sp = body; is_pair(p); p = cdr(p)) { if (is_pair(car(p))) @@ -72416,7 +72522,7 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun len = s7_list_length(sc, body); #if OPTIMIZE_PRINT - fprintf(stderr, "%s[%d]: %s %s %ld\n", __func__, __LINE__, DISPLAY(func), DISPLAY(args), len); + fprintf(stderr, "%s[%d]: %s %s %ld\n", __func__, __LINE__, display(func), display(args), len); #endif if (len < 0) /* (define (hi) 1 . 2) */ @@ -72483,6 +72589,7 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun clear_all_optimizations(sc, body); else { + /* fprintf(stderr, "%d %s result: %d\n", __LINE__, display(body), result); */ if (result >= RECUR_BODY) /* (is_safe_closure_body(body)) */ { int32_t nvars; @@ -72493,11 +72600,15 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun if (nvars > 0) { annotate_args(sc, body, cleared_args); + /* this does not do what we want, but full tree annotation clobbers optimizer settings! + * we need a syntax-aware tree walker that does what check* does + */ fx_tree(sc, body, (is_pair(car(args))) ? caar(args) : car(args), (nvars > 1) ? ((is_pair(cadr(args))) ? caadr(args) : cadr(args)) : NULL); } } + if ((unstarred_lambda) || (nvars == 1)) { if (is_null(cdr(body))) @@ -72514,13 +72625,6 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun if (check_recur(sc, func, nvars, args, car(body))) set_safe_closure_body(body); } -#if 0 - if (((sc->got_tc) || (sc->got_rec)) && - (!is_rec_op(optimize_op(car(body)))) && - (!is_tc_op(optimize_op(car(body)))) && - (!is_symbol(cadar(body)))) /* and let as start */ - fprintf(stderr, "%s[%d]: %s %d %s\n", __func__, __LINE__, DISPLAY(func), nvars, DISPLAY(body)); -#endif } } } @@ -72542,7 +72646,7 @@ static int32_t check_lambda_1(s7_scheme *sc, bool optl) s7_pointer code, body, form; int32_t arity = 0; - /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, DISPLAY(sc->code)); */ + /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(sc->code)); */ form = sc->code; if ((sc->safety > NO_SAFETY) && @@ -72851,7 +72955,7 @@ static s7_pointer check_case(s7_scheme *sc) else sc->value = carc; return(NULL); } - push_stack_no_args(sc, OP_CASE_G_G, sc->code); + push_stack_no_args_direct(sc, OP_CASE_G_G, sc->code); sc->code = carc; return(carc); } @@ -73113,7 +73217,7 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer s { s7_pointer binding; #if S7_DEBUGGING - if (cdr(form) != sc->code) fprintf(stderr, "%s[%d]: form: %s, code: %s\n", __func__, __LINE__, DISPLAY_80(form), DISPLAY_80(sc->code)); + if (cdr(form) != sc->code) fprintf(stderr, "%s[%d]: form: %s, code: %s\n", __func__, __LINE__, display_80(form), display_80(sc->code)); #endif binding = car(start); @@ -73126,7 +73230,7 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer s if (is_optimized(cadr(binding))) { - /* if (not_in_heap(form)) fprintf(stderr, "unheap %s\n", DISPLAY_80(form)); */ + /* if (not_in_heap(form)) fprintf(stderr, "unheap %s\n", display_80(form)); */ if (is_null(cddr(sc->code))) /* one statement body */ { @@ -73137,7 +73241,7 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer s pair_set_syntax_op(form, OP_LET_opSSq_E_OLD); if (c_callee(cadr(binding)) == g_assq) pair_set_syntax_op(form, OP_LET_opaSSq_E_OLD); - set_opt3_sym(cdr(sc->code), caddr(cadr(binding))); + set_opt3_sym(cdr(sc->code), caddadr(binding)); return(sc->code); } if (is_fxable(sc, cadr(binding))) @@ -73154,7 +73258,7 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer s if (c_callee(cadr(binding)) == g_assq) pair_set_syntax_op(form, OP_LET_opaSSq_OLD); else pair_set_syntax_op(form, OP_LET_opSSq_OLD); - set_opt3_sym(cdr(sc->code), caddr(cadr(binding))); + set_opt3_sym(cdr(sc->code), caddadr(binding)); } else { @@ -73401,7 +73505,7 @@ static bool op_named_let_1(s7_scheme *sc, s7_pointer args) /* args = vals in dec { s7_pointer body, x; s7_int n; - /* fprintf(stderr, "named: %s: %s\n", DISPLAY_80(sc->code)); */ + /* fprintf(stderr, "named: %s: %s\n", display_80(sc->code)); */ if (is_null(opt3_lamlet(sc->code))) { @@ -73472,6 +73576,11 @@ static bool op_let1(s7_scheme *sc) while (true) { +#if S7_DEBUGGING + /* can this be a multiple-value? */ + if (is_multiple_value(sc->value)) + fprintf(stderr, "%s[%d]: value is a multiple-value? %s from %s\n", __func__, __LINE__, display(sc->value), display(sc->code)); +#endif sc->args = cons(sc, sc->value, sc->args); if (is_pair(sc->code)) { @@ -73480,7 +73589,7 @@ static bool op_let1(s7_scheme *sc) sc->value = fx_call(sc, x); else { - push_stack(sc, OP_LET1, sc->args, cdr(sc->code)); + push_stack(sc, OP_LET1, sc->args, cdr(sc->code)); /* cdr direct? */ sc->code = car(x); return(false); } @@ -73568,7 +73677,7 @@ static bool op_let_unchecked(s7_scheme *sc) /* not named, but has vars */ sc->value = fx_call(sc, x); else { - push_stack(sc, OP_LET1, sc->args, cdr(sc->code)); + push_stack(sc, OP_LET1, sc->args, cdr(sc->code)); /* cdr direct? */ sc->code = car(x); return(false); /* goto EVAL */ } @@ -74011,36 +74120,43 @@ static bool check_let_star(s7_scheme *sc) else { if (is_null(cdar(sc->code))) - check_let_one_var(sc, form, car(sc->code)); /* (let* ((var...))...) -> (let ((var...))...) */ - else { - pair_set_syntax_op(form, (fxable) ? OP_LET_STAR_FX_OLD : OP_LET_STAR2); - set_opt2_con(sc->code, cadaar(sc->code)); + check_let_one_var(sc, form, car(sc->code)); /* (let* ((var...))...) -> (let ((var...))...) */ + if (optimize_op(form) >= OP_LET_FX_OLD) + { + if ((not_in_heap(form)) && + (body_is_safe(sc, sc->unused, cdr(sc->code), true) >= SAFE_BODY)) + set_opt3_let(sc->code, make_permanent_let(sc, car(sc->code))); + else + { + set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */ + set_opt3_let(sc->code, sc->nil); + } + } } - } - if (optimize_op(form) == OP_LET_STAR_FX_OLD) - { - if ((is_null(cddr(sc->code))) && - (is_fxable(sc, cadr(sc->code)))) + else /* multiple variables */ { - annotate_arg(sc, cdr(sc->code), sc->envir); - pair_set_syntax_op(form, OP_LET_STAR_FX_A_OLD); /* does this ever happen? */ + s7_pointer last_var; + if (fxable) + { + pair_set_syntax_op(form, OP_LET_STAR_FX); + if ((is_null(cddr(sc->code))) && + (is_fxable(sc, cadr(sc->code)))) + { + annotate_arg(sc, cdr(sc->code), sc->envir); + pair_set_syntax_op(form, OP_LET_STAR_FX_A); /* does this ever happen? */ + } + } + else pair_set_syntax_op(form, OP_LET_STAR2); + set_opt2_con(sc->code, cadaar(sc->code)); + + for (last_var = caaar(sc->code), vars = cdar(sc->code); is_pair(vars); last_var = caar(vars), vars = cdr(vars)) + if (has_fx(cdar(vars))) + fx_tree(sc, cdar(vars), last_var, NULL); } } } - if (optimize_op(form) >= OP_LET_FX_OLD) - { - if ((not_in_heap(form)) && - (is_null(cdar(sc->code))) && /* else order of vars in permanent let can confuse fx_tree */ - (body_is_safe(sc, sc->unused, cdr(sc->code), true) >= SAFE_BODY)) - set_opt3_let(sc->code, make_permanent_let(sc, car(sc->code))); - else - { - set_optimize_op(form, optimize_op(form) + 1); - set_opt3_let(sc->code, sc->nil); - } - } /* let_star_unchecked... */ set_current_code(sc, form); @@ -74093,9 +74209,19 @@ static inline bool op_let_star1(s7_scheme *sc) * To get around this requires find_symbol or s7_tree_memq in check_let_star, * both (much) more expensive than making a useless frame!. */ + + /* TODO: can this be moved to the first call point above? */ + uint64_t let_counter = S7_LLONG_MAX; while (true) { - new_frame_with_slot(sc, sc->envir, sc->envir, caar(sc->code), sc->value); + if (let_counter == sc->capture_let_counter) + make_slot_1(sc, sc->envir, caar(sc->code), sc->value); + else + { + new_frame_with_slot(sc, sc->envir, sc->envir, caar(sc->code), sc->value); + let_counter = sc->capture_let_counter; + } + sc->code = cdr(sc->code); if (is_pair(sc->code)) { @@ -74105,7 +74231,7 @@ static inline bool op_let_star1(s7_scheme *sc) sc->value = fx_call(sc, x); else { - push_stack(sc, OP_LET_STAR1, sc->args, sc->code); + push_stack_direct(sc, OP_LET_STAR1, sc->args, sc->code); sc->code = car(x); return(true); } @@ -74126,40 +74252,44 @@ static inline bool op_let_star1(s7_scheme *sc) return(false); } -static void op_let_star_fx_new(s7_scheme *sc) +static void op_let_star_fx(s7_scheme *sc) { - s7_pointer e, p; + /* fx safe does not mean we can dispense with the inner frames (curlet is safe for example) */ + s7_pointer p; + uint64_t let_counter = S7_LLONG_MAX; start_let(sc); - new_frame(sc, sc->envir, e); - /* since each value is fx safe, there are no internal closures over the on-going stack of lets here (so use one frame) */ - sc->envir = e; for (p = car(sc->code); is_pair(p); p = cdr(p)) - make_slot_1(sc, e, caar(p), fx_call(sc, cdar(p))); - sc->code = T_Pair(cdr(sc->code)); -} - -static void op_let_star_fx_old(s7_scheme *sc) -{ - start_let(sc); - activate_permanent_let_star(sc, opt3_let(sc->code), car(sc->code)); + { + s7_pointer val; + val = fx_call(sc, cdar(p)); /* eval in outer env */ + if (let_counter == sc->capture_let_counter) + make_slot_1(sc, sc->envir, caar(p), val); + else + { + new_frame_with_slot(sc, sc->envir, sc->envir, caar(p), val); + let_counter = sc->capture_let_counter; + } + } sc->code = T_Pair(cdr(sc->code)); } -static void op_let_star_fx_a_old(s7_scheme *sc) -{ - start_let(sc); - activate_permanent_let_star(sc, opt3_let(sc->code), car(sc->code)); - sc->value = fx_call(sc, cdr(sc->code)); -} - -static void op_let_star_fx_a_new(s7_scheme *sc) +static void op_let_star_fx_a(s7_scheme *sc) { - s7_pointer e, p; + s7_pointer p; + uint64_t let_counter = S7_LLONG_MAX; start_let(sc); - new_frame(sc, sc->envir, e); - sc->envir = e; for (p = car(sc->code); is_pair(p); p = cdr(p)) - make_slot_1(sc, e, caar(p), fx_call(sc, cdar(p))); + { + s7_pointer val; + val = fx_call(sc, cdar(p)); + if (let_counter == sc->capture_let_counter) + make_slot_1(sc, sc->envir, caar(p), val); + else + { + new_frame_with_slot(sc, sc->envir, sc->envir, caar(p), val); + let_counter = sc->capture_let_counter; + } + } sc->value = fx_call(sc, cdr(sc->code)); } @@ -74264,7 +74394,7 @@ static bool op_letrec_unchecked(s7_scheme *sc) } sc->args = let_slots(sc->envir); if (!(sc->args)) sc->args = sc->nil; - push_stack(sc, OP_LETREC1, sc->args, sc->code); + push_stack_direct(sc, OP_LETREC1, sc->args, sc->code); sc->code = slot_expression(sc->args); return(true); } @@ -74281,7 +74411,7 @@ static bool op_letrec1(s7_scheme *sc) sc->args = next_slot(sc->args); if (tis_slot(sc->args)) { - push_stack(sc, OP_LETREC1, sc->args, sc->code); + push_stack_direct(sc, OP_LETREC1, sc->args, sc->code); sc->code = slot_expression(sc->args); return(false); } @@ -74335,7 +74465,7 @@ static bool op_letrec_star_unchecked(s7_scheme *sc) let_set_slots(sc->envir, x); sc->args = let_slots(sc->envir); if (!(sc->args)) sc->args = sc->nil; - push_stack(sc, OP_LETREC_STAR1, sc->args, sc->code); + push_stack_direct(sc, OP_LETREC_STAR1, sc->args, sc->code); sc->code = slot_expression(sc->args); return(true); } @@ -74436,6 +74566,12 @@ static s7_pointer check_let_temporarily(s7_scheme *sc) pair_set_syntax_op(form, (all_fx) ? ((is_null(cdar(sc->code))) ? OP_LET_TEMP_FX_1 : OP_LET_TEMP_FX) : OP_LET_TEMP_S7); for (x = car(sc->code); is_pair(x); x = cdr(x)) annotate_arg(sc, cdar(x), sc->envir); + + if ((optimize_op(form) == OP_LET_TEMP_FX_1) && (is_pair(cdr(sc->code))) && (is_null(cddr(sc->code))) && (is_fxable(sc, cadr(sc->code)))) + { + annotate_arg(sc, cdr(sc->code), sc->envir); + pair_set_syntax_op(form, OP_LET_TEMP_A_A); + } } else { @@ -74466,7 +74602,8 @@ static void op_let_temp_unchecked(s7_scheme *sc) { set_current_code(sc, sc->code); sc->code = cdr(sc->code); - push_stack(sc, OP_GC_PROTECT, sc->args = list_4(sc, car(sc->code), sc->nil, sc->nil, sc->nil), sc->code); + sc->args = list_4(sc, car(sc->code), sc->nil, sc->nil, sc->nil); + push_stack_direct(sc, OP_GC_PROTECT, sc->args, sc->code); /* sc->args: varlist, settees, old_values, new_values */ } @@ -74488,7 +74625,7 @@ static bool op_let_temp_init1(s7_scheme *sc) { if (is_pair(settee)) { - push_stack(sc, OP_LET_TEMP_INIT1, sc->args, sc->code); + push_stack_direct(sc, OP_LET_TEMP_INIT1, sc->args, sc->code); sc->code = settee; return(true); } @@ -74517,7 +74654,7 @@ static goto_t op_let_temp_init2(s7_scheme *sc) (symbol_has_setter(settee)) || (is_pair(new_value))) { - push_stack(sc, OP_LET_TEMP_INIT2, sc->args, sc->code); + push_stack_direct(sc, OP_LET_TEMP_INIT2, sc->args, sc->code); sc->code = list_3(sc, sc->set_symbol, settee, new_value); return(goto_top_no_pop); } @@ -74532,11 +74669,11 @@ static goto_t op_let_temp_init2(s7_scheme *sc) } car(sc->args) = cadr(sc->args); pop_stack(sc); - /* push_stack(sc, OP_LET_TEMP_DONE, sc->args, sc->code); */ /* we fall into LET_TEMP_DONE below so this seems redundant */ + /* push_stack_direct(sc, OP_LET_TEMP_DONE, sc->args, sc->code); */ /* we fall into LET_TEMP_DONE below so this seems redundant */ sc->code = cdr(sc->code); if (is_pair(sc->code)) { - push_stack(sc, OP_LET_TEMP_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_LET_TEMP_DONE, sc->args, sc->code); return(goto_begin); } sc->value = sc->nil; /* so (let-temporarily (<vars)) -> () like begin I guess */ @@ -74555,7 +74692,7 @@ static bool op_let_temp_done1(s7_scheme *sc) if ((!is_symbol(settee)) || (symbol_has_setter(settee))) { - push_stack(sc, OP_LET_TEMP_DONE1, sc->args, sc->code); + push_stack_direct(sc, OP_LET_TEMP_DONE1, sc->args, sc->code); if ((is_pair(sc->value)) || (is_symbol(sc->value))) sc->code = list_3(sc, sc->set_symbol, settee, list_2(sc, sc->quote_symbol, sc->value)); else sc->code = list_3(sc, sc->set_symbol, settee, sc->value); @@ -74604,7 +74741,7 @@ static void op_let_temp_s7(s7_scheme *sc) /* all entries are of the form ((*s7* static void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer code, s7_pointer let) { /* called in call/cc, call-with-exit and, catch (unwind to catch) */ - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); sc->args = T_Pos(args); sc->code = code; sc->envir = let; @@ -74671,6 +74808,16 @@ static void op_let_temp_fx_1(s7_scheme *sc) /* one entry */ sc->code = cdr(sc->code); } +static s7_pointer fx_let_temp_a_a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer result; + op_let_temp_fx_1(sc); + result = fx_call(sc, sc->code); + pop_stack(sc); + let_temp_unwind(sc, sc->code, sc->args); + return(result); +} + static void op_let_temp_setter(s7_scheme *sc) { s7_pointer var, slot, sym, e; @@ -74822,7 +74969,7 @@ static void op_and_safe_aa(s7_scheme *sc) static void op_and_safe_p1(s7_scheme *sc) /* sc->code: (and (func...) (fx...)...) */ { sc->code = cdr(sc->code); - push_stack_no_args(sc, OP_AND_SAFE_P_REST, sc->code); + push_stack_no_args_direct(sc, OP_AND_SAFE_P_REST, sc->code); sc->code = car(sc->code); } @@ -74831,7 +74978,7 @@ static bool op_and_safe_p2(s7_scheme *sc) sc->value = fx_call(sc, cdr(sc->code)); if (is_false(sc, sc->value)) return(true); sc->code = cddr(sc->code); - push_stack_no_args(sc, OP_AND_SAFE_P_REST, sc->code); + push_stack_no_args_direct(sc, OP_AND_SAFE_P_REST, sc->code); sc->code = car(sc->code); return(false); } @@ -74969,8 +75116,6 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re } if (is_fxable(sc, test)) { - /* if (one_branch) fprintf(stderr, "%s\n", DISPLAY_80(sc->code)); */ - if (optimize_op(test) == OP_OR_2) { pair_set_syntax_op(form, choose_if_optc(IF_OR2, one_branch, reversed, not_case)); @@ -75052,7 +75197,6 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re { if (is_safe_symbol(test)) { - /* if (!not_case) fprintf(stderr, "if_s: %s\n", DISPLAY_80(form)); */ pair_set_syntax_op(form, choose_if_optc(IF_S, one_branch, reversed, not_case)); if ((optimize_op(form) == OP_IF_S_P_P) && (is_fxable(sc, caddr(sc->code)))) @@ -75464,7 +75608,7 @@ static s7_pointer check_define(s7_scheme *sc) if (is_syntactic_symbol(func)) /* (define and a) */ { if (sc->safety > NO_SAFETY) - s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined\n", DISPLAY(func)); + s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined\n", display(func)); set_local(func); } if ((is_pair(cadr(sc->code))) && /* look for (define sym (lambda ...)) and treat it like (define (sym ...)...) */ @@ -75491,7 +75635,7 @@ static s7_pointer check_define(s7_scheme *sc) if (is_syntactic_symbol(func)) /* (define (and a) a) */ { if (sc->safety > NO_SAFETY) - s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined\n", DISPLAY(func)); + s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined\n", display(func)); set_local(func); } if (starred) @@ -75551,7 +75695,7 @@ static bool op_define_unchecked(s7_scheme *sc) } else { - s7_pointer x,args; + s7_pointer x, args; /* a closure. If we called this same code earlier (a local define), the only thing * that is new here is the environment -- we can't blithely save the closure object * in opt2 somewhere, and pick it up the next time around (since call/cc might take @@ -75569,7 +75713,7 @@ static bool op_define_unchecked(s7_scheme *sc) static s7_pointer make_funclet(s7_scheme *sc, s7_pointer new_func, s7_pointer func_name, s7_pointer outer_env) { s7_pointer new_env, arg; - /* fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, DISPLAY(new_func), DISPLAY(func_name), DISPLAY(outer_env)); */ + /* fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(new_func), display(func_name), display(outer_env)); */ new_cell_no_check(sc, new_env, T_LET | T_FUNCLET); let_id(new_env) = ++sc->let_number; set_outlet(new_env, outer_env); @@ -75722,7 +75866,7 @@ static void op_define_constant1(s7_scheme *sc) static inline void define_funchecked(s7_scheme *sc) { s7_pointer new_func, code, slot; - /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, DISPLAY(sc->code)); */ + /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(sc->code)); */ code = cdr(sc->code); sc->value = caar(code); /* func name */ @@ -75783,7 +75927,7 @@ static s7_pointer check_define_macro(s7_scheme *sc, opcode_t op) if (is_syntactic_symbol(x)) { if (sc->safety > NO_SAFETY) - s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined\n", DISPLAY(x)); + s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined\n", display(x)); set_local(x); } if (is_constant_symbol(sc, x)) @@ -76039,7 +76183,7 @@ static goto_t op_macroexpand(s7_scheme *sc) if (is_pair(caar(sc->code))) /* (macroexpand ((symbol->value 'mac) (+ 1 2))) */ { - push_stack_no_args(sc, OP_MACROEXPAND_1, sc->code); + push_stack_no_args_direct(sc, OP_MACROEXPAND_1, sc->code); sc->code = caar(sc->code); return(goto_eval); } @@ -76316,7 +76460,7 @@ static bool op_cond_unchecked(s7_scheme *sc) sc->value = fx_call(sc, car(sc->code)); /* false -> fall through into cond1 */ return(false); } - push_stack_no_args(sc, OP_COND1, sc->code); /* true -> push cond1, goto eval */ + push_stack_no_args_direct(sc, OP_COND1, sc->code); /* true -> push cond1, goto eval */ sc->code = opt3_any(sc->code); /* caar */ return(true); } @@ -76330,7 +76474,7 @@ static bool op_cond_simple(s7_scheme *sc) /* no => */ sc->value = fx_call(sc, car(sc->code)); return(false); } - push_stack_no_args(sc, OP_COND1_SIMPLE, sc->code); + push_stack_no_args_direct(sc, OP_COND1_SIMPLE, sc->code); sc->code = opt3_any(sc->code); /* caar */ return(true); } @@ -76344,7 +76488,7 @@ static bool op_cond_simple_p(s7_scheme *sc) /* no =>, no null or multiform cons sc->value = fx_call(sc, car(sc->code)); return(false); } - push_stack_no_args(sc, OP_COND1_SIMPLE_P, sc->code); + push_stack_no_args_direct(sc, OP_COND1_SIMPLE_P, sc->code); sc->code = opt3_any(sc->code); /* caar */ return(true); } @@ -76410,7 +76554,7 @@ static bool op_cond1(s7_scheme *sc) sc->value = fx_call(sc, car(sc->code)); else { - push_stack_no_args(sc, OP_COND1, sc->code); + push_stack_no_args_direct(sc, OP_COND1, sc->code); sc->code = caar(sc->code); sc->cur_op = optimize_op(sc->code); return(true); @@ -76454,7 +76598,7 @@ static bool op_cond1_simple(s7_scheme *sc) sc->value = fx_call(sc, car(sc->code)); else { - push_stack_no_args(sc, OP_COND1_SIMPLE, sc->code); + push_stack_no_args_direct(sc, OP_COND1_SIMPLE, sc->code); sc->code = caar(sc->code); sc->cur_op = optimize_op(sc->code); return(true); @@ -76487,7 +76631,7 @@ static bool op_cond1_simple_p(s7_scheme *sc) sc->value = fx_call(sc, car(sc->code)); else { - push_stack_no_args(sc, OP_COND1_SIMPLE_P, sc->code); + push_stack_no_args_direct(sc, OP_COND1_SIMPLE_P, sc->code); sc->code = caar(sc->code); return(false); } @@ -76579,7 +76723,7 @@ static bool op_cond_feed(s7_scheme *sc) sc->value = fx_call(sc, car(sc->code)); else { - push_stack_no_args(sc, OP_COND_FEED_1, sc->code); + push_stack_no_args_direct(sc, OP_COND_FEED_1, sc->code); sc->code = caar(sc->code); return(true); } @@ -76622,7 +76766,7 @@ static bool feed_to(s7_scheme *sc) } sc->args = list_1(sc, sc->value); /* not plist here */ } - push_stack(sc, OP_FEED_TO_1, sc->args, sc->code); + push_stack_direct(sc, OP_FEED_TO_1, sc->args, sc->code); sc->code = cadr(sc->code); /* need to evaluate the target function */ return(false); } @@ -76650,7 +76794,7 @@ static inline s7_pointer check_set(s7_scheme *sc) { s7_pointer form; form = sc->code; - /* fprintf(stderr, "check_set: %s\n", DISPLAY_80(sc->code)); */ + /* fprintf(stderr, "check_set: %s\n", display_80(sc->code)); */ sc->code = cdr(sc->code); if (!is_pair(sc->code)) @@ -76851,6 +76995,7 @@ static inline s7_pointer check_set(s7_scheme *sc) { if (settee == cadr(value)) { + /* TODO?: +/- via (c_callee(value)) as g_add_2/g_subtract_2 - integer case */ pair_set_syntax_op(form, OP_INCREMENT_SS); set_opt2_sym(sc->code, caddr(value)); } @@ -76878,7 +77023,6 @@ static inline s7_pointer check_set(s7_scheme *sc) { pair_set_syntax_op(form, OP_INCREMENT_SA); annotate_arg(sc, cddr(value), sc->envir); /* this sets c_callee(arg) */ - /* increment_sc does not happen much here */ set_opt2_pair(sc->code, cddr(value)); } else @@ -77332,7 +77476,8 @@ static s7_pointer op_set2(s7_scheme *sc) if (sc->args != sc->nil) { push_op_stack(sc, sc->list_set_function); - push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->value), s7_append(sc, cdr(sc->args), sc->code)); + sc->code = s7_append(sc, cdr(sc->args), sc->code); + push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->value), sc->code); sc->code = car(sc->args); } else eval_error(sc, "list set!: not enough arguments: ~S", 35, sc->code); @@ -77349,7 +77494,8 @@ static s7_pointer op_set2(s7_scheme *sc) if (sc->args != sc->nil) { push_op_stack(sc, sc->vector_set_function); - push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->value), s7_append(sc, cdr(sc->args), sc->code)); + sc->code = s7_append(sc, cdr(sc->args), sc->code); + push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->value), sc->code); sc->code = car(sc->args); } else eval_error(sc, "vector set!: not enough arguments: ~S", 37, sc->code); @@ -77398,7 +77544,7 @@ static bool op_set_with_let_1(s7_scheme *sc) } sc->code = e; /* 'e above, an expression we need to evaluate */ sc->args = list_2(sc, b, x); /* can't reuse sc->args here via set-car! etc */ - push_stack(sc, OP_SET_WITH_LET_2, sc->args, sc->code); + push_stack_direct(sc, OP_SET_WITH_LET_2, sc->args, sc->code); sc->cur_op = optimize_op(sc->code); return(true); } @@ -77453,7 +77599,7 @@ static void op_increment_sp(s7_scheme *sc) sc->code = cdr(sc->code); sym = symbol_to_slot(sc, car(sc->code)); push_stack(sc, OP_INCREMENT_SP_1, sym, sc->code); - sc->code = T_Pair(opt2_pair(sc->code)); /* caddr(cadr(sc->code)); */ + sc->code = T_Pair(opt2_pair(sc->code)); /* caddadr(sc->code); */ } static void op_increment_sp_1(s7_scheme *sc) @@ -77552,7 +77698,8 @@ static goto_t set_implicit_c_object(s7_scheme *sc, s7_pointer cx) } else { - push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), s7_append(sc, cddr(settee), cdr(sc->code))); + sc->code = s7_append(sc, cddr(settee), cdr(sc->code)); + push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), sc->code); sc->code = cadr(settee); } sc->cur_op = optimize_op(sc->code); @@ -77663,7 +77810,8 @@ static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer cx, s7_pointer form) } } push_op_stack(sc, sc->vector_set_function); /* vector_setter(cx) has wrong args */ - push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), s7_append(sc, cddr(settee), cdr(sc->code))); /* i.e. rest(args) + val */ + sc->code = s7_append(sc, cddr(settee), cdr(sc->code)); /* i.e. rest(args) + val */ + push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), sc->code); sc->code = cadr(settee); sc->cur_op = optimize_op(sc->code); return(goto_top_no_pop); @@ -77808,7 +77956,8 @@ static goto_t set_implicit_pair(s7_scheme *sc, s7_pointer cx) /* code: ((ls (is_pair(val))) { push_op_stack(sc, sc->list_set_function); - push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), s7_append(sc, cddr(settee), cdr(sc->code))); + sc->code = s7_append(sc, cddr(settee), cdr(sc->code)); + push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), sc->code); sc->code = index; sc->cur_op = optimize_op(sc->code); return(goto_top_no_pop); @@ -77970,7 +78119,8 @@ static goto_t set_implicit_function(s7_scheme *sc, s7_pointer cx) /* (let ((lst } } push_op_stack(sc, c_function_setter(cx)); - push_stack(sc, OP_EVAL_ARGS1, sc->nil, s7_append(sc, cddar(sc->code), cdr(sc->code))); + sc->value = s7_append(sc, cddar(sc->code), cdr(sc->code)); + push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->value); sc->code = cadar(sc->code); } else @@ -78032,7 +78182,11 @@ static goto_t set_implicit_closure(s7_scheme *sc, s7_pointer cx) { if (is_null(cddar(sc->code))) push_stack(sc, OP_EVAL_ARGS1, sc->nil, cdr(sc->code)); - else push_stack(sc, OP_EVAL_ARGS1, sc->nil, s7_append(sc, cddar(sc->code), cdr(sc->code))); + else + { + sc->value = s7_append(sc, cddar(sc->code), cdr(sc->code)); + push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->value); + } sc->code = cadar(sc->code); } } @@ -78089,7 +78243,7 @@ static goto_t set_implicit_syntax(s7_scheme *sc, s7_pointer cx) */ sc->args = cdar(sc->code); sc->code = cadr(sc->code); - push_stack(sc, OP_SET_WITH_LET_1, sc->args, sc->code); + push_stack_direct(sc, OP_SET_WITH_LET_1, sc->args, sc->code); sc->cur_op = optimize_op(sc->code); return(goto_top_no_pop); } @@ -78196,14 +78350,14 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_p { /* here any (unsafe?) closure or jumping-op (call/cc) or shadowed variable is trouble */ s7_pointer p; - if (DO_PRINT) fprintf(stderr, "do_is_safe: %s\n", DISPLAY_80(body)); + if (DO_PRINT) fprintf(stderr, "do_is_safe: %s\n", display_80(body)); /* sc->code is the complete do form (do ...) */ for (p = body; is_pair(p); p = cdr(p)) { s7_pointer expr; expr = car(p); - if (DO_PRINT) fprintf(stderr, " %s\n", DISPLAY_80(expr)); + if (DO_PRINT) fprintf(stderr, " %s\n", display_80(expr)); if (is_pair(expr)) { s7_pointer x; @@ -78282,15 +78436,15 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_p (!do_is_safe(sc, cdar(vars), steppers, nv, has_set))) { sc->x = sc->nil; - {if (DO_PRINT) fprintf(stderr, "bad stepper %d, step %s\n", __LINE__, DISPLAY_80(cdar(vars))); return(false);} + {if (DO_PRINT) fprintf(stderr, "bad stepper %d, step %s\n", __LINE__, display_80(cdar(vars))); return(false);} } } sc->x = sc->nil; if (!do_is_safe(sc, caddr(expr), steppers, nv, has_set)) - {if (DO_PRINT) fprintf(stderr, "bad init %d: %s\n", __LINE__, DISPLAY(caddr(expr))); return(false);} + {if (DO_PRINT) fprintf(stderr, "bad init %d: %s\n", __LINE__, display(caddr(expr))); return(false);} if ((is_pair(cdddr(expr))) && (!do_is_safe(sc, cdddr(expr), steppers, nv, has_set))) - {if (DO_PRINT) fprintf(stderr, "bad step %d, %s\n", __LINE__, DISPLAY(cadddr(expr))); return(false);} + {if (DO_PRINT) fprintf(stderr, "bad step %d, %s\n", __LINE__, display(cadddr(expr))); return(false);} if (DO_PRINT) fprintf(stderr, "do is ok\n"); break; } @@ -78327,7 +78481,7 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_p if (res) { if (DO_PRINT) - fprintf(stderr, "set! end %d, settee: %s in %s\n", __LINE__, DISPLAY(settee), DISPLAY(caaddr(sc->code))); + fprintf(stderr, "set! end %d, settee: %s in %s\n", __LINE__, display(settee), display(caaddr(sc->code))); return(false); } } @@ -78443,7 +78597,7 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_p } /* is_symbol(x=car(expr)) */ else { - {if (DO_PRINT) fprintf(stderr, "%d, %s not a symbol\n", __LINE__, DISPLAY_80(x)); return(false);} + {if (DO_PRINT) fprintf(stderr, "%d, %s not a symbol\n", __LINE__, display_80(x)); return(false);} /* car(expr) ("x") is not a symbol: ((mus-data loc) chan) for example * but that's actually safe since it's just in effect vector-ref * there are several examples in dlocsig: ((group-speakers group) i) etc @@ -78552,7 +78706,7 @@ static inline bool do_tree_has_definers(s7_scheme *sc, s7_pointer tree) (!symbol_is_in_list(sc, cadr(p)))))) { #if DO_PRINT - fprintf(stderr, "definer: %s\n", DISPLAY(pp)); + fprintf(stderr, "definer: %s\n", display(pp)); #endif return(true); } @@ -78574,7 +78728,7 @@ static s7_pointer check_do(s7_scheme *sc) form = sc->code; code = cdr(sc->code); #if DO_PRINT - fprintf(stderr, "check_do: %s %s\n", DISPLAY_80(form), DISPLAY_80(sc->envir)); + fprintf(stderr, "check_do: %s %s\n", display_80(form), display_80(sc->envir)); #endif if ((!is_pair(code)) || /* (do . 1) */ @@ -78641,29 +78795,57 @@ static s7_pointer check_do(s7_scheme *sc) eval_error(sc, "stray dot in do body? ~A", 24, form); pair_set_syntax_op(form, OP_DO_UNCHECKED); - end = cadr(code); + if ((!is_pair(end)) || (!is_fxable(sc, car(end)))) { #if DO_PRINT - fprintf(stderr, "%s end unsafe\n", DISPLAY_80(form)); + fprintf(stderr, "%s end unsafe\n", display_80(form)); if (is_pair(end)) fprintf(stderr, " %d %s\n", is_fxable(sc, car(end)), op_names[optimize_op(car(end))]); #endif if (is_null(cddr(code))) { - /* no body, end not fxable */ + /* no body, end not fxable (if eval car(end) might be unopt) */ s7_pointer p; - fxify_step_exprs(sc, code); - for (p = car(code); is_pair(p); p = cdr(p)) + for (p = car(code); is_pair(p); p = cdr(p)) /* gather var names */ { s7_pointer var; var = car(p); - if ((!has_fx(cdr(var))) || - ((is_pair(cddr(var))) && (!has_fx(cddr(var))))) - break; + if (is_pair(cddr(var))) /* if no step expr it's safe in other step exprs 16-Apr-19 */ + set_match_symbol(car(var)); + } + for (p = car(code); is_pair(p); p = cdr(p)) /* look for stuff like (do ((i 0 j) (j 0 (+ j 1))) ((= j 3) i)) */ + { + s7_pointer var, val; + var = car(p); + val = cddr(var); + if (is_pair(val)) + { + clear_match_symbol(car(var)); /* ignore current var */ + if (tree_match(car(val))) + { + s7_pointer q; + for (q = car(code); is_pair(q); q = cdr(q)) + clear_match_symbol(caar(q)); + return(code); + } + } + set_match_symbol(car(var)); } + for (p = car(code); is_pair(p); p = cdr(p)) /* clear var names */ + clear_match_symbol(caar(p)); + if (is_null(p)) { + fxify_step_exprs(sc, code); + for (p = car(code); is_pair(p); p = cdr(p)) + { + s7_pointer var; + var = car(p); + if ((!has_fx(cdr(var))) || + ((is_pair(cddr(var))) && (!has_fx(cddr(var))))) + return(code); + } pair_set_syntax_op(form, OP_DO_NO_BODY_FX_VARS); return(sc->nil); } @@ -78814,13 +78996,13 @@ static s7_pointer check_do(s7_scheme *sc) for (q = vars; q != p; q = cdr(q)) clear_match_symbol(caar(q)); #if DO_PRINT - fprintf(stderr, " step not fx safe: %s\n ", DISPLAY(var)); + fprintf(stderr, " step not fx safe: %s\n ", display(var)); if (!is_fxable(sc, cadr(var))) - fprintf(stderr, "can't fxify %s (%s)\n", DISPLAY(cadr(var)), op_names[optimize_op(cadr(var))]); + fprintf(stderr, "can't fxify %s (%s)\n", display(cadr(var)), op_names[optimize_op(cadr(var))]); if ((is_pair(cddr(var))) && (!is_fxable(sc, caddr(var)))) - fprintf(stderr, "can't fxify %s (%s)\n", DISPLAY(caddr(var)), op_names[optimize_op(caddr(var))]); + fprintf(stderr, "can't fxify %s (%s)\n", display(caddr(var)), op_names[optimize_op(caddr(var))]); if ((is_symbol(cadr(var))) && (is_definer_or_binder(cadr(var)))) - fprintf(stderr, "%s is a definer or binder\n", DISPLAY(cadr(var))); + fprintf(stderr, "%s is a definer or binder\n", display(cadr(var))); #endif return(fxify_step_exprs(sc, code)); } @@ -78851,7 +79033,7 @@ static s7_pointer check_do(s7_scheme *sc) for (q = vars; is_pair(q); q = cdr(q)) clear_match_symbol(caar(q)); #if DO_PRINT - fprintf(stderr, "var matched in %s\n", DISPLAY(car(val))); + fprintf(stderr, "var matched in %s\n", display(car(val))); #endif if (is_null(body)) got_pending = true; @@ -78864,7 +79046,7 @@ static s7_pointer check_do(s7_scheme *sc) clear_match_symbol(caar(p)); /* end and steps look ok! */ - /* TODO: split out the constant cases from OP_DOX so dox_ex is less repetitive + /* TODO: split out the constant cases from OP_DOX so op_dox is less repetitive * 1-var, no body, 1-expr body, steppers=1|2 */ for (p = vars; is_pair(p); p = cdr(p)) @@ -78980,14 +79162,6 @@ static s7_pointer check_do(s7_scheme *sc) annotate_arg(sc, body, collect_variables(sc, vars, sc->nil)); fx_tree(sc, body, last_stepper, previous_stepper); } - -#if 0 - { - bool has_set = false; - if (do_is_safe(sc, body, (previous_stepper) ? set_plist_2(sc, last_stepper, previous_stepper) : set_plist_1(sc, last_stepper), sc->nil, &has_set)) - fx_tree(sc, body, last_stepper, previous_stepper); - } -#endif } #if (DO_PRINT) fprintf(stderr, " dox\n"); @@ -79019,7 +79193,6 @@ static bool has_safe_steppers(s7_scheme *sc, s7_pointer frame) if (is_t_integer(val)) { sc->pc = 0; - reset_opts(sc); if (int_optimize(sc, step_expr)) set_safe_stepper(slot); else clear_safe_stepper(slot); @@ -79029,7 +79202,6 @@ static bool has_safe_steppers(s7_scheme *sc, s7_pointer frame) if (is_real(val)) { sc->pc = 0; - reset_opts(sc); if (float_optimize(sc, step_expr)) set_safe_stepper(slot); else clear_safe_stepper(slot); @@ -79081,7 +79253,7 @@ static bool op_dox_init(s7_scheme *sc) return(false); /* goto BEGIN */ } -static goto_t dox_ex(s7_scheme *sc) +static goto_t op_dox(s7_scheme *sc) { /* any number of steppers using dox exprs, end also dox, body and end result arbitrary. * since all these exprs are local, we don't need to jump until the body @@ -79127,6 +79299,7 @@ static goto_t dox_ex(s7_scheme *sc) end = cadr(sc->code); endp = car(end); endf = c_callee(end); + if (is_true(sc, sc->value = endf(sc, endp))) { sc->code = cdr(end); @@ -79221,7 +79394,6 @@ static goto_t dox_ex(s7_scheme *sc) } return(goto_do_end_clauses); } - while (true) { s7_pointer slt; @@ -79274,7 +79446,6 @@ static goto_t dox_ex(s7_scheme *sc) fd = o->v[0].fd; while (true) { - sc->pc = 0; fd(o); slot_set_value(stepper, stepf(sc, stepa)); if (is_true(sc, sc->value = endf(sc, endp))) @@ -79284,6 +79455,23 @@ static goto_t dox_ex(s7_scheme *sc) } } } + + if ((stepf == fx_add_t1) && (stepper == let_slots(sc->envir)) && (is_t_integer(slot_value(stepper)))) + { + s7_int i; + i = integer(slot_value(stepper)); + while (true) + { + bodyf(sc, body); + slot_set_value(stepper, make_integer(sc, ++i)); + if (is_true(sc, sc->value = endf(sc, endp))) + { + sc->code = cdr(end); + return(goto_do_end_clauses); + } + } + } + while (true) { bodyf(sc, body); @@ -79372,6 +79560,7 @@ static goto_t dox_ex(s7_scheme *sc) s7_pointer p; bool use_opts = false; int32_t body_len = 0; + opt_info *body[32]; p = code; if ((!no_cell_opt(code)) && @@ -79379,8 +79568,9 @@ static goto_t dox_ex(s7_scheme *sc) { if (setjmp(sc->opt_exit) == 0) { + int32_t k; sc->pc = 0; - for (; is_pair(p); p = cdr(p), body_len++) + for (k = 0; (is_pair(p)) && (k < 32); k++, p = cdr(p), body_len++) { opt_info *start; start = sc->opts[sc->pc]; @@ -79391,6 +79581,7 @@ static goto_t dox_ex(s7_scheme *sc) break; } oo_idp_nr_fixup(start); + body[k] = start; } use_opts = is_null(p); } @@ -79421,14 +79612,8 @@ static goto_t dox_ex(s7_scheme *sc) { if (use_opts) { - sc->pc = 0; for (i = 0; i < body_len; i++) - { - opt_info *o; - o = sc->opts[sc->pc]; - o->v[0].fp(o); - sc->pc++; - } + body[i]->v[0].fp(body[i]); } else { @@ -79458,7 +79643,7 @@ static goto_t dox_ex(s7_scheme *sc) if ((is_syntactic_pair(code)) || (is_syntactic_symbol(car(code)))) { - push_stack_no_args(sc, OP_DOX_STEP_P, sc->code); + push_stack_no_args_direct(sc, OP_DOX_STEP_P, sc->code); if (is_syntactic_pair(code)) sc->cur_op = (opcode_t)optimize_op(code); @@ -79475,7 +79660,6 @@ static goto_t dox_ex(s7_scheme *sc) pair_set_syntax_op(form, OP_DOX_INIT); sc->code = T_Pair(cddr(sc->code)); push_stack_no_args(sc, (intptr_t)((is_null(cdr(sc->code))) ? OP_DOX_STEP_P : OP_DOX_STEP), cdr(form)); - return(goto_begin); } @@ -79491,7 +79675,7 @@ static bool op_dox_step(s7_scheme *sc) sc->code = cdadr(sc->code); return(true); } - push_stack_no_args(sc, OP_DOX_STEP, sc->code); + push_stack_no_args_direct(sc, OP_DOX_STEP, sc->code); sc->code = T_Pair(cddr(sc->code)); return(false); } @@ -79508,7 +79692,7 @@ static bool op_dox_step_p(s7_scheme *sc) sc->code = cdadr(sc->code); return(true); } - push_stack_no_args(sc, OP_DOX_STEP_P, sc->code); + push_stack_no_args_direct(sc, OP_DOX_STEP_P, sc->code); sc->code = caddr(sc->code); return(false); } @@ -79598,6 +79782,8 @@ static void op_dox_pending_no_body(s7_scheme *sc) sc->envir = frame; sc->temp10 = sc->nil; test = cadr(sc->code); + + let_set_has_pending_value(sc->envir); if ((all_steps) && (!tis_slot(next_slot(next_slot(let_slots(frame)))))) { @@ -79609,24 +79795,27 @@ static void op_dox_pending_no_body(s7_scheme *sc) if (is_true(sc, sc->value = fx_call(sc, test))) { sc->code = cdr(test); + let_clear_has_pending_value(sc->envir); return; } - slot_set_pending_value(slot1, fx_call(sc, slot_expression(slot1))); + slot_simply_set_pending_value(slot1, fx_call(sc, slot_expression(slot1))); /* use pending_value for GC protection */ slot_set_value(slot2, fx_call(sc, slot_expression(slot2))); slot_set_value(slot1, slot_pending_value(slot1)); } } + while (true) { s7_pointer slt; if (is_true(sc, sc->value = fx_call(sc, test))) { sc->code = cdr(test); + let_clear_has_pending_value(sc->envir); return; } for (slt = slots; tis_slot(slt); slt = next_slot(slt)) if (slot_has_expression(slt)) - slot_set_pending_value(slt, fx_call(sc, slot_expression(slt))); + slot_simply_set_pending_value(slt, fx_call(sc, slot_expression(slt))); for (slt = slots; tis_slot(slt); slt = next_slot(slt)) if (slot_has_expression(slt)) slot_set_value(slt, slot_pending_value(slt)); @@ -79637,14 +79826,18 @@ static bool op_do_no_vars(s7_scheme *sc) { s7_pointer p, form; int32_t i; + opt_info *body[32]; form = sc->code; set_current_code(sc, form); sc->code = cdr(sc->code); sc->pc = 0; - reset_opts(sc); - for (i = 0, p = cddr(sc->code); is_pair(p); i++, p = cdr(p)) - if (!cell_optimize(sc, p)) - break; + + for (i = 0, p = cddr(sc->code); (is_pair(p)) && (i < 32); i++, p = cdr(p)) + { + body[i] = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + } if (is_null(p)) { s7_pointer end; @@ -79660,8 +79853,7 @@ static bool op_do_no_vars(s7_scheme *sc) sc->code = cdr(end); return(true); } - sc->pc = 0; - sc->opts[0]->v[0].fp(sc->opts[0]); + body[0]->v[0].fp(body[0]); } } else @@ -79685,16 +79877,9 @@ static bool op_do_no_vars(s7_scheme *sc) sc->code = cdr(end); return(true); } - sc->pc = -1; for (k = 0; k < i; k++) - { - opt_info *o; - o = sc->opts[++sc->pc]; - o->v[0].fp(o); - } - } - } - } + body[k]->v[0].fp(body[k]); + }}} /* back out */ pair_set_syntax_op(form, OP_DO_NO_VARS_NO_OPT); sc->envir = new_frame_in_env(sc, sc->envir); @@ -79704,7 +79889,7 @@ static bool op_do_no_vars(s7_scheme *sc) sc->code = cdadr(sc->code); return(true); } - push_stack_no_args(sc, OP_DO_NO_VARS_NO_OPT_1, sc->code); + push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1, sc->code); sc->code = T_Pair(cddr(sc->code)); return(false); } @@ -79724,7 +79909,7 @@ static bool op_do_no_vars_no_opt_1(s7_scheme *sc) sc->code = cdadr(sc->code); return(true); } - push_stack_no_args(sc, OP_DO_NO_VARS_NO_OPT_1, sc->code); + push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1, sc->code); sc->code = T_Pair(cddr(sc->code)); return(false); } @@ -79750,7 +79935,7 @@ static void op_do_no_body_fx_vars(s7_scheme *sc) } if (steppers == 1) let_set_dox_slot1(frame, stepper); sc->envir = frame; - push_stack_no_args(sc, (intptr_t)((steppers == 1) ? OP_DO_NO_BODY_FX_VARS_STEP_1 : OP_DO_NO_BODY_FX_VARS_STEP), sc->code); + push_stack_no_args_direct(sc, (intptr_t)((steppers == 1) ? OP_DO_NO_BODY_FX_VARS_STEP_1 : OP_DO_NO_BODY_FX_VARS_STEP), sc->code); sc->code = caadr(sc->code); } @@ -79766,7 +79951,7 @@ static bool op_do_no_body_fx_vars_step(s7_scheme *sc) if (slot_has_expression(slot)) slot_set_value(slot, fx_call(sc, slot_expression(slot))); - push_stack_no_args(sc, OP_DO_NO_BODY_FX_VARS_STEP, sc->code); + push_stack_no_args_direct(sc, OP_DO_NO_BODY_FX_VARS_STEP, sc->code); sc->code = caadr(sc->code); return(false); } @@ -79779,21 +79964,20 @@ static bool op_do_no_body_fx_vars_step_1(s7_scheme *sc) return(true); } slot_set_value(let_dox_slot1(sc->envir), fx_call(sc, slot_expression(let_dox_slot1(sc->envir)))); - push_stack_no_args(sc, OP_DO_NO_BODY_FX_VARS_STEP_1, sc->code); + push_stack_no_args_direct(sc, OP_DO_NO_BODY_FX_VARS_STEP_1, sc->code); sc->code = caadr(sc->code); return(false); } static bool do_step1(s7_scheme *sc) { - /* on each iteration, each arg incr expr is evaluated and the value placed in caddr while we cdr down args */ while (true) { s7_pointer code; if (is_null(sc->args)) { s7_pointer x; - for (x = sc->code; is_pair(x); x = cdr(x)) /* sc->code here is the original sc->args list */ + for (x = sc->code; is_pair(x); x = cdr(x)) /* sc->code here is the original sc->args list */ { slot_set_value(car(x), slot_pending_value(car(x))); slot_clear_has_pending_value(car(x)); @@ -79805,17 +79989,12 @@ static bool do_step1(s7_scheme *sc) if (has_fx(code)) { sc->value = fx_call(sc, code); -#if S7_DEBUGGING - /* can values happen here even in error? */ - if (is_multiple_value(sc->value)) - fprintf(stderr, "got multiple values! %s\n", DISPLAY(sc->value)); -#endif - slot_set_pending_value(car(sc->args), sc->value); + slot_set_pending_value(car(sc->args), sc->value); /* consistently slower if slot_simply_set... here? */ sc->args = cdr(sc->args); /* go to next step var */ } else { - push_stack(sc, OP_DO_STEP2, sc->args, sc->code); + push_stack_direct(sc, OP_DO_STEP2, sc->args, sc->code); sc->code = car(code); return(false); } @@ -79841,7 +80020,7 @@ static bool op_do_step(s7_scheme *sc) * any unstepped vars in the do var section are not in this list, so * (do ((i 0 (+ i 1)) (j 2)) ...) arrives here with sc->args: '(slot<((+ i 1)=expr, 0=pending_value>)) */ - push_stack(sc, OP_DO_END, sc->args, sc->code); + push_stack_direct(sc, OP_DO_END, sc->args, sc->code); sc->args = car(sc->args); /* the var data lists */ sc->code = sc->args; /* save the top of the list */ if (do_step1(sc)) return(true); @@ -79924,7 +80103,7 @@ static bool opt_do_copy(s7_scheme *sc, opt_info *o, s7_int start, s7_int stop) return(false); } -static bool simple_do_ex(s7_scheme *sc, s7_pointer code) +static bool op_simple_do_1(s7_scheme *sc, s7_pointer code) { #if (!WITH_GMP) s7_pointer body, step_expr, step_var, ctr_slot, end_slot; @@ -79987,7 +80166,6 @@ static bool simple_do_ex(s7_scheme *sc, s7_pointer code) for (i = start; i < stop; i++) { slot_set_value(ctr_slot, make_integer(sc, i)); - sc->pc = 1; fpt(sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p)); } } @@ -79996,7 +80174,6 @@ static bool simple_do_ex(s7_scheme *sc, s7_pointer code) for (i = start; i < stop; i++) { slot_set_value(ctr_slot, make_integer(sc, i)); - sc->pc = 0; fp(o); } } @@ -80036,7 +80213,6 @@ static bool simple_do_ex(s7_scheme *sc, s7_pointer code) for (i = start; i >= stop; i--) { slot_set_value(ctr_slot, make_integer(sc, i)); - sc->pc = 0; fp(o); } } @@ -80096,7 +80272,7 @@ static bool simple_do_ex(s7_scheme *sc, s7_pointer code) static bool op_simple_do(s7_scheme *sc) { /* body might not be safe in this case, but the step and end exprs are easy - * simple_do: set up local env, check end (c_c?), goto simple_do_ex + * simple_do: set up local env, check end (c_c?), goto op_simple_do_1 * if latter gets s7_optimize, run locally, else goto simple_do_step. */ s7_pointer end, code, body; @@ -80123,9 +80299,9 @@ static bool op_simple_do(s7_scheme *sc) body = cddr(code); if ((is_null(cdr(body))) && /* one expr in body */ (is_pair(car(body))) && /* and it is a pair */ - (is_symbol(cadr(caddr(caar(code))))) && /* caar=(i 0 (+ i 1)), caddr=(+ i 1), so this is apparently checking that the stepf is reasonable? */ - (is_t_integer(caddr(caddr(caar(code))))) && - (simple_do_ex(sc, sc->code))) + (is_symbol(cadaddr(caar(code)))) && /* caar=(i 0 (+ i 1)), caddr=(+ i 1), so this is apparently checking that the stepf is reasonable? */ + (is_t_integer(caddaddr(caar(code)))) && + (op_simple_do_1(sc, sc->code))) return(true); /* goto DO_END_CLAUSES */ push_stack(sc, OP_SIMPLE_DO_STEP, sc->args, code); @@ -80164,7 +80340,7 @@ static bool op_simple_do_step(s7_scheme *sc) return(true); } - push_stack(sc, OP_SIMPLE_DO_STEP, sc->args, code); + push_stack_direct(sc, OP_SIMPLE_DO_STEP, sc->args, sc->code); sc->code = T_Pair(cddr(code)); return(false); } @@ -80187,7 +80363,7 @@ static bool op_safe_do_step(s7_scheme *sc) sc->code = cdadr(sc->code); return(true); } - push_stack(sc, OP_SAFE_DO_STEP, sc->args, sc->code); + push_stack_direct(sc, OP_SAFE_DO_STEP, sc->args, sc->code); sc->code = T_Pair(opt2_pair(sc->code)); return(false); } @@ -80203,7 +80379,7 @@ static bool op_safe_dotimes_step(s7_scheme *sc) sc->code = cdadr(sc->code); return(true); } - push_stack(sc, OP_SAFE_DOTIMES_STEP, sc->args, sc->code); + push_stack_direct(sc, OP_SAFE_DOTIMES_STEP, sc->args, sc->code); sc->code = opt2_pair(sc->code); /* here we know the body has more than one form */ push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); sc->code = car(sc->code); @@ -80221,7 +80397,7 @@ static bool op_safe_dotimes_step_p(s7_scheme *sc) sc->code = cdadr(sc->code); return(true); } - push_stack(sc, OP_SAFE_DOTIMES_STEP_P, sc->args, sc->code); + push_stack_direct(sc, OP_SAFE_DOTIMES_STEP_P, sc->args, sc->code); sc->code = opt2_pair(sc->code); return(false); } @@ -80282,7 +80458,7 @@ static inline bool op_dotimes_step_p(s7_scheme *sc) return(true); } } - push_stack(sc, OP_DOTIMES_STEP_P, sc->args, code); + push_stack_direct(sc, OP_DOTIMES_STEP_P, sc->args, sc->code); sc->code = caddr(code); return(false); } @@ -80290,11 +80466,14 @@ static inline bool op_dotimes_step_p(s7_scheme *sc) static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool safe_step) { s7_int end; + /* fprintf(stderr, "opt_dotimes: %s\n", display(code)); */ + if (safe_step) set_safe_stepper(sc->args); else set_safe_stepper(let_dox_slot1(sc->envir)); /* I think safe_step means the stepper is completely unproblematic */ + if (is_null(cdr(code))) { s7_function func; @@ -80332,10 +80511,9 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf fd = o1->v[0].fd; end8 = end - 8; while (integer(stepper) < end8) - LOOP_8(sc->pc = 1; f0(integer(stepper), fd(o1)); integer(stepper)++); + LOOP_8(f0(integer(stepper), fd(o1)); integer(stepper)++); while (integer(stepper) < end) { - sc->pc = 1; f0(integer(stepper), fd(o1)); integer(stepper)++; } @@ -80343,10 +80521,7 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf else { for (; integer(stepper) < end; integer(stepper)++) - { - sc->pc = 0; - fd(o); - } + fd(o); } } else @@ -80366,22 +80541,15 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf } else { - int32_t first_pc = 0; if (fp == opt_if_bp) fp = opt_if_bp_nr; else { if (fp == opt_if_nbp_fs) - { - fp = opt_if_nbp_fs_nr; - first_pc = 2; - } + fp = opt_if_nbp_fs_nr; } for (; integer(stepper) < end; integer(stepper)++) - { - sc->pc = first_pc; - fp(o); - } + fp(o); } } } @@ -80416,12 +80584,9 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf else { for (; integer(stepper) < end; integer(stepper)++) - { - sc->pc = 0; - fi(o); - } + fi(o); /* if fi = opt_i_i_s for example, -> o->v[2].i_i_f(integer(slot_value(o->v[1].p))) - * and o->v[2].i_i_f can be pulled out leaving a loop of sc->pc = 0; ov2(integer(slot_value(o->v[1].p))); + * and o->v[2].i_i_f can be pulled out leaving a loop of ov2(integer(slot_value(o->v[1].p))); */ } } @@ -80449,7 +80614,6 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf { while (true) { - sc->pc = 0; fp(o); step = integer(slot_value(step_slot)) + 1; slot_set_value(step_slot, make_integer(sc, step)); @@ -80477,16 +80641,21 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf { s7_pointer p; s7_int body_len; + opt_info *body[32]; + int32_t k; body_len = s7_list_length(sc, code); sc->pc = 0; - reset_opts(sc); + if (body_len >= 32) return(false); if (!no_float_opt(code)) { - for (p = code; is_pair(p); p = cdr(p)) - if (!float_optimize(sc, p)) - break; + for (k = 0, p = code; is_pair(p); k++, p = cdr(p)) + { + body[k] = sc->opts[sc->pc]; + if (!float_optimize(sc, p)) + break; + } if (is_pair(p)) { pc_fallback(sc, 0); @@ -80502,12 +80671,8 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf slot_set_value(sc->args, stepper = make_mutable_integer(sc, integer(slot_value(sc->args)))); for (; integer(stepper) < end; integer(stepper)++) { - sc->pc = 0; for (i = 0; i < body_len; i++) - { - sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]); - sc->pc++; - } + body[i]->v[0].fd(body[i]); } clear_mutable_integer(stepper); } @@ -80519,13 +80684,8 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf while (true) { s7_int step; - sc->pc = 0; for (i = 0; i < body_len; i++) - { - sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]); - sc->pc++; - } - + body[i]->v[0].fd(body[i]); step = integer(slot_value(step_slot)) + 1; slot_set_value(step_slot, make_integer(sc, step)); if (step == integer(slot_value(end_slot))) break; @@ -80538,7 +80698,8 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf } /* not float opt */ - for (p = code; is_pair(p); p = cdr(p)) + sc->pc = 0; + for (k = 0, p = code; is_pair(p); k++, p = cdr(p)) { opt_info *start; start = sc->opts[sc->pc]; @@ -80546,6 +80707,7 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf break; if (start->v[0].fp == d_to_p) start->v[0].fp = d_to_p_nr; + body[k] = start; } if (is_null(p)) @@ -80558,14 +80720,8 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf slot_set_value(sc->args, stepper = make_mutable_integer(sc, integer(slot_value(sc->args)))); for (; integer(stepper) < end; integer(stepper)++) { - sc->pc = 0; for (i = 0; i < body_len; i++) - { - opt_info *o; - o = sc->opts[sc->pc]; - o->v[0].fp(o); - sc->pc++; - } + body[i]->v[0].fp(body[i]); } clear_mutable_integer(stepper); } @@ -80577,15 +80733,8 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf while (true) { s7_int step; - sc->pc = 0; for (i = 0; i < body_len; i++) - { - opt_info *o; - o = sc->opts[sc->pc]; - o->v[0].fp(o); - sc->pc++; - } - + body[i]->v[0].fp(body[i]); step = integer(slot_value(step_slot)) + 1; slot_set_value(step_slot, make_integer(sc, step)); if (step == integer(slot_value(end_slot))) break; @@ -80608,6 +80757,11 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) bool let_star; s7_pointer old_e, stepper; s7_int body_len, var_len, k, end; + #define O_SIZE 32 + opt_info *body[O_SIZE], *vars[O_SIZE]; + + memset((void *)body, 0, O_SIZE * sizeof(opt_info *)); /* placate the damned compiler */ + memset((void *)vars, 0, O_SIZE * sizeof(opt_info *)); /* do_let with non-float vars doesn't get many fixable hits */ let_code = caddr(scc); @@ -80615,7 +80769,7 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) return(fall_through); let_body = cddr(let_code); body_len = s7_list_length(sc, let_body); - if (body_len <= 0) return(fall_through); + if ((body_len <= 0) || (body_len >= 32)) return(fall_through); let_star = (symbol_syntax_op_checked(let_code) == OP_LET_STAR); let_vars = cadr(let_code); set_safe_stepper(step_slot); @@ -80628,8 +80782,7 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) return(fall_through); sc->pc = 0; - reset_opts(sc); - for (var_len = 0, p = let_vars; is_pair(p); var_len++, p = cdr(p)) + for (var_len = 0, p = let_vars; (is_pair(p)) && (var_len < 32); var_len++, p = cdr(p)) { s7_pointer expr; if ((!is_pair(car(p))) || @@ -80637,6 +80790,7 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) (!is_pair(cdar(p)))) return(fall_through); expr = cdar(p); + vars[var_len] = sc->opts[sc->pc]; if (!float_optimize(sc, expr)) /* each of these needs to set the associated variable */ { sc->envir = old_e; @@ -80650,13 +80804,15 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) for (p = let_vars; is_pair(p); p = cdr(p)) make_slot_1(sc, sc->envir, caar(p), s7_make_mutable_real(sc, 1.5)); - for (p = let_body; is_pair(p); p = cdr(p)) - if (!float_optimize(sc, p)) - { - sc->envir = old_e; - return(fall_through); - } - + for (k = 0, p = let_body; is_pair(p); k++, p = cdr(p)) + { + body[k] = sc->opts[sc->pc]; + if (!float_optimize(sc, p)) + { + sc->envir = old_e; + return(fall_through); + } + } if (!is_null(p)) /* no hits in s7test or snd-test */ { sc->envir = old_e; @@ -80667,12 +80823,13 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) let_set_slots(sc->envir, reverse_slots(sc, let_slots(sc->envir))); ip = slot_value(step_slot); + /* fprintf(stderr, "do_let: %s\n", display(scc)); */ + if (body_len == 1) { if (var_len == 1) { s7_pointer xp; - int32_t pc2; opt_info *first, *o; s7_double (*f1)(opt_info *o); s7_double (*f2)(opt_info *o); @@ -80680,27 +80837,23 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) first = sc->opts[0]; f1 = first->v[0].fd; integer(ip) = numerator(stepper); - sc->pc = 0; set_real(xp, f1(first)); - pc2 = ++sc->pc; - o = sc->opts[pc2]; + o = body[0]; f2 = o->v[0].fd; f2(o); if ((f2 == opt_fmv) && (f1 == opt_d_dd_ff_o2) && (first->v[3].d_dd_f == add_d_dd) && - (slot_symbol(step_slot) == slot_symbol(o->v[2].p))) /* and _dv et al throughout (so sc->pc ignored) etc */ + (slot_symbol(step_slot) == slot_symbol(o->v[2].p))) { opt_info *o1, *o2, *o3; s7_d_v_t vf1, vf2, vf3, vf4; s7_d_vd_t vf5, vf6; s7_d_vid_t vf7; void *obj1, *obj2, *obj3, *obj4, *obj5, *obj6, *obj7; - - sc->pc = pc2; - o1 = o->sc->opts[o->sc->pc + 1]; - o2 = o->sc->opts[o->sc->pc + 3]; - o3 = o->sc->opts[o->sc->pc + 5]; + o1 = o->v[12].o1; + o2 = o->v[13].o1; + o3 = o->v[14].o1; vf1 = first->v[4].d_v_f; vf2 = first->v[5].d_v_f; vf3 = o1->v[2].d_v_f; @@ -80726,12 +80879,11 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) } else { + for (k = numerator(stepper) + 1; k < end; k++) { integer(ip) = k; - sc->pc = 0; set_real(xp, f1(first)); - sc->pc = pc2; f2(o); } } @@ -80743,29 +80895,25 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) s7_pointer s1, s2; s1 = let_slots(sc->envir); s2 = next_slot(s1); + for (k = numerator(stepper); k < end; k++) { integer(ip) = k; - sc->pc = 0; - set_real(slot_value(s1), sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc])); - sc->pc++; - set_real(slot_value(s2), sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc])); - sc->pc++; - sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]); + set_real(slot_value(s1), vars[0]->v[0].fd(vars[0])); + set_real(slot_value(s2), vars[1]->v[0].fd(vars[1])); + body[0]->v[0].fd(body[0]); } } /* body_len == 1 and var_len == 2 */ else { + for (k = numerator(stepper); k < end; k++) { + int32_t n; integer(ip) = k; - sc->pc = 0; - for (p = let_slots(sc->envir); tis_slot(p); p = next_slot(p)) - { - set_real(slot_value(p), sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc])); - sc->pc++; - } - sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]); + for (n = 0, p = let_slots(sc->envir); tis_slot(p); n++, p = next_slot(p)) + set_real(slot_value(p), vars[n]->v[0].fd(vars[n])); + body[0]->v[0].fd(body[0]); } } } @@ -80776,15 +80924,13 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) { s7_pointer s1; s1 = let_slots(sc->envir); + for (k = numerator(stepper); k < end; k++) { integer(ip) = k; - sc->pc = 0; - set_real(slot_value(s1), sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc])); - sc->pc++; - sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]); - sc->pc++; - sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]); + set_real(slot_value(s1), vars[0]->v[0].fd(vars[0])); + body[0]->v[0].fd(body[0]); + body[1]->v[0].fd(body[1]); } } else @@ -80793,17 +80939,10 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) { int32_t i; integer(ip) = k; - sc->pc = 0; - for (p = let_slots(sc->envir); tis_slot(p); p = next_slot(p)) - { - set_real(slot_value(p), sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc])); - sc->pc++; - } + for (i = 0, p = let_slots(sc->envir); tis_slot(p); i++, p = next_slot(p)) + set_real(slot_value(p), vars[i]->v[0].fd(vars[i])); for (i = 0; i < body_len; i++) - { - sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]); - sc->pc++; - } + body[i]->v[0].fd(body[i]); } } } @@ -80825,7 +80964,7 @@ static bool dotimes(s7_scheme *sc, s7_pointer code, bool safe_case) return(opt_dotimes(sc, cddr(code), code, safe_case)); } -static goto_t safe_dotimes_ex(s7_scheme *sc) +static goto_t op_safe_dotimes(s7_scheme *sc) { s7_pointer init_val, form; form = sc->code; @@ -80898,6 +81037,7 @@ static goto_t safe_dotimes_ex(s7_scheme *sc) (opt_dotimes(sc, cddr(code), code, true))) return(goto_safe_do_end_clauses); set_unsafe_do(code); + /* see dotimes-data -- very little comes here that can be handled locally */ push_stack(sc, OP_SAFE_DOTIMES_STEP_P, sc->args, code); return(goto_eval); } @@ -80907,7 +81047,6 @@ static goto_t safe_dotimes_ex(s7_scheme *sc) (opt_dotimes(sc, sc->code, code, true))) return(goto_safe_do_end_clauses); set_unsafe_do(code); - set_opt2_pair(code, sc->code); push_stack(sc, OP_SAFE_DOTIMES_STEP, sc->args, code); return(goto_begin); @@ -80920,7 +81059,7 @@ static goto_t safe_dotimes_ex(s7_scheme *sc) return(goto_begin); } -static goto_t safe_do_ex(s7_scheme *sc) +static goto_t op_safe_do(s7_scheme *sc) { /* body is safe, step = +1, end is = or >=, but stepper and end might be set (or at least indirectly exported) in the body: * (let ((lst ())) (do ((i 0 (+ i 1))) ((= i 10)) (let ((j (min i 100))) (set! lst (cons j lst)))) lst) @@ -80994,10 +81133,10 @@ static goto_t safe_do_ex(s7_scheme *sc) step_slot = let_dox_slot1(sc->envir); if (slot_symbol(step_slot) != cadr(body)) { - s7_int step, end; + s7_int step, endi; s7_pointer val_slot, fx_p, step_val; - end = integer(slot_value(let_dox_slot2(sc->envir))); + endi = integer(slot_value(let_dox_slot2(sc->envir))); val_slot = symbol_to_slot(sc, cadr(body)); fx_p = cddr(body); step = integer(slot_value(step_slot)); @@ -81007,25 +81146,21 @@ static goto_t safe_do_ex(s7_scheme *sc) { slot_set_value(val_slot, fx_call(sc, fx_p)); integer(step_val) = ++step; - if (step == end) /* geq not needed here -- we're leq end and stepping by +1 all ints */ + if (step == endi) /* geq not needed here -- we're leq endi and stepping by +1 all ints */ { clear_mutable_integer(step_val); sc->value = sc->T; sc->code = cdadr(code); return(goto_safe_do_end_clauses); - } - } - } - } - } + }}}}} sc->code = cddr(code); set_unsafe_do(sc->code); set_opt2_pair(code, sc->code); - push_stack(sc, OP_SAFE_DO_STEP, sc->args, code); /* (do ((i 0 (+ i 1))) ((= i 2)) (set! (str i) #\a)) */ + push_stack(sc, OP_SAFE_DO_STEP, sc->args, code); /* (do ((i 0 (+ i 1))) ((= i 2)) (set! (str i) #\a)) */ return(goto_begin); } -static goto_t dotimes_p_ex(s7_scheme *sc) +static goto_t op_dotimes_p(s7_scheme *sc) { s7_pointer end, code, init_val, end_val, slot, form, old_e; /* (do ... (set! args ...)) -- one line, syntactic */ @@ -81084,8 +81219,7 @@ static goto_t dotimes_p_ex(s7_scheme *sc) set_step_end(sc->args); /* dotimes step is by 1 */ if (dotimes(sc, code, false)) - return(goto_do_end_clauses); - + return(goto_do_end_clauses); /* not safe_do here */ slot_set_value(sc->args, old_init); sc->envir = old_e; /* free_cell(sc, sc->envir) beforehand is not safe */ sc->args = old_args; @@ -81097,7 +81231,7 @@ static goto_t dotimes_p_ex(s7_scheme *sc) return(goto_eval); } -static goto_t do_init_ex(s7_scheme *sc) +static goto_t op_do_init_1(s7_scheme *sc) { s7_pointer x, y, z; while (true) /* at start, first value is the loop (for GC protection?), returning sc->value is the next value */ @@ -81114,7 +81248,7 @@ static goto_t do_init_ex(s7_scheme *sc) init = car(init); if (is_pair(init)) { - push_stack(sc, OP_DO_INIT, sc->args, cdr(sc->code)); /* OP_DO_INIT only used here */ + push_stack(sc, OP_DO_INIT, sc->args, cdr(sc->code)); /* OP_DO_INIT only used here */ sc->code = init; return(goto_eval); } @@ -81164,7 +81298,7 @@ static bool op_do_init(s7_scheme *sc) { if (is_multiple_value(sc->value)) /* (do ((i (values 1 2)))...) */ eval_error_no_return(sc, sc->wrong_type_arg_symbol, "do: variable initial value can't be ~S", 38, cons(sc, sc->values_symbol, sc->value)); - if (do_init_ex(sc) == goto_eval) return(false); + if (op_do_init_1(sc) == goto_eval) return(false); return(true); } @@ -81188,7 +81322,7 @@ static bool do_unchecked(s7_scheme *sc) sc->args = sc->nil; /* the evaluated var-data */ sc->value = sc->code; /* protect it */ sc->code = car(sc->code); /* the vars */ - return(do_init_ex(sc) == goto_eval); + return(op_do_init_1(sc) == goto_eval); } static bool op_do_end(s7_scheme *sc) @@ -81198,7 +81332,7 @@ static bool op_do_end(s7_scheme *sc) { if (!has_fx(cdr(sc->args))) { - push_stack(sc, OP_DO_END1, sc->args, sc->code); + push_stack_direct(sc, OP_DO_END1, sc->args, sc->code); sc->code = cadr(sc->args); /* evaluate the end expr */ return(true); } @@ -81248,8 +81382,8 @@ static goto_t op_do_end1(s7_scheme *sc) if (is_pair(sc->code)) { if (is_null(car(sc->args))) - push_stack(sc, OP_DO_END, sc->args, sc->code); - else push_stack(sc, OP_DO_STEP, sc->args, sc->code); + push_stack_direct(sc, OP_DO_END, sc->args, sc->code); + else push_stack_direct(sc, OP_DO_STEP, sc->args, sc->code); return(goto_begin); } if (is_null(car(sc->args))) /* no steppers */ @@ -81267,7 +81401,7 @@ static inline bool closure_is_ok_1(s7_scheme *sc, s7_pointer code, uint16_t type { s7_pointer f; #if S7_DEBUGGING - if ((type & (T_ONE_FORM | T_MULTIFORM)) == 0) fprintf(stderr, "%s %s: type has no body bits\n", __func__, DISPLAY(code)); + if ((type & (T_ONE_FORM | T_MULTIFORM)) == 0) fprintf(stderr, "%s %s: type has no body bits\n", __func__, display(code)); #endif f = lookup_unexamined(sc, car(code)); if ((f == opt1_lambda_unchecked(code)) || @@ -81284,7 +81418,7 @@ static inline bool closure_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t ty { s7_pointer f; #if S7_DEBUGGING - if ((type & (T_ONE_FORM | T_MULTIFORM)) != 0) fprintf(stderr, "%s %s: type has body bits\n", __func__, DISPLAY(code)); + if ((type & (T_ONE_FORM | T_MULTIFORM)) != 0) fprintf(stderr, "%s %s: type has body bits\n", __func__, display(code)); #endif f = lookup_unexamined(sc, car(code)); if ((f == opt1_lambda_unchecked(code)) || @@ -81338,7 +81472,7 @@ static bool closure_star_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type { s7_pointer val; #if S7_DEBUGGING - if ((type & (T_ONE_FORM | T_MULTIFORM)) != 0) fprintf(stderr, "%s %s: type has body bits\n", __func__, DISPLAY(code)); + if ((type & (T_ONE_FORM | T_MULTIFORM)) != 0) fprintf(stderr, "%s %s: type has body bits\n", __func__, display(code)); #endif val = lookup_unexamined(sc, car(code)); if ((val == opt1_lambda_unchecked(code)) || @@ -81408,7 +81542,7 @@ static goto_t op_unknown(s7_scheme *sc, s7_pointer f) if (!f) /* can be NULL if unbound variable */ return(unknown_unknown(sc)); #if SHOW_EVAL_OPS - fprintf(stderr, "%s %s\n", __func__, DISPLAY(f)); + fprintf(stderr, "%s %s\n", __func__, display(f)); #endif code = sc->code; @@ -81468,6 +81602,41 @@ static goto_t op_unknown(s7_scheme *sc, s7_pointer f) return(fixup_unknown_op(code, f, OP_S)); } +static bool fxify_closure_star_g(s7_scheme *sc, s7_pointer f, s7_pointer code) +{ + if ((!has_methods(f)) && + (closure_star_arity_to_int(sc, f) != 0)) + { + int32_t hop = 0; + bool safe_case; + if (is_immutable_and_stable(sc, car(code))) hop = 1; + + annotate_arg(sc, cdr(code), sc->envir); + set_opt3_arglen(code, small_int(1)); + safe_case = is_safe_closure(f); + + if ((safe_case) && (is_null(cdr(closure_args(f))))) + set_optimize_op(code, hop + OP_SAFE_CLOSURE_STAR_A1); + else + { + if (lambda_has_simple_defaults(f)) + { + if (arglist_has_rest(sc, closure_args(f))) + fixup_unknown_op(code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_FX_1 : OP_CLOSURE_STAR_FX)); + else fixup_unknown_op(code, f, hop + ((safe_case) ? + ((is_null(cdr(closure_args(f)))) ? OP_SAFE_CLOSURE_STAR_A1 : OP_SAFE_CLOSURE_STAR_A) : OP_CLOSURE_STAR_A)); + return(true); + } + } + if (safe_case) + { + fixup_unknown_op(code, f, hop + OP_SAFE_CLOSURE_STAR_FX_1); + return(true); + } + } + return(false); +} + static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f) { s7_pointer code; @@ -81475,13 +81644,13 @@ static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f) if (!f) /* can be NULL if unbound variable */ return(unknown_unknown(sc)); #if SHOW_EVAL_OPS - fprintf(stderr, "%s %s\n", __func__, DISPLAY(f)); + fprintf(stderr, "%s %s\n", __func__, display(f)); #endif code = sc->code; #if S7_DEBUGGING if (is_pair(cadr(code))) - fprintf(stderr, "%s[%d]: arg is a pair: %s\n", __func__, __LINE__, DISPLAY(code)); + fprintf(stderr, "%s[%d]: arg is a pair: %s\n", __func__, __LINE__, display(code)); #endif sym_case = is_normal_symbol(cadr(code)); if ((sym_case) && @@ -81532,12 +81701,7 @@ static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f) if (is_null(cdr(body))) { if (is_fxable(sc, car(body))) - { - annotate_arg(sc, body, sc->envir); - set_safe_optimize_op(code, hop + ((sym_case) ? OP_SAFE_CLOSURE_S_A : OP_SAFE_CLOSURE_C_A)); - set_closure_has_fx(f); - fx_tree(sc, body, car(closure_args(f)), NULL); - } + fxify_safe_closure_s(sc, f, code, sc->envir, sym_case, hop); else { /* hop if is_constant(sc, car(code)) is not foolproof here (see t967.scm): @@ -81561,23 +81725,7 @@ static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f) break; case T_CLOSURE_STAR: - if ((!has_methods(f)) && - (closure_star_arity_to_int(sc, f) != 0)) - { - int32_t hop = 0; - if (is_immutable_and_stable(sc, car(code))) hop = 1; - - annotate_arg(sc, cdr(code), sc->envir); - set_opt3_arglen(code, small_int(1)); - if (lambda_has_simple_defaults(closure_body(f))) - { - if (arglist_has_rest(sc, closure_args(f))) - return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_FX_1 : OP_CLOSURE_STAR_FX))); - return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A))); - } - if (is_safe_closure(f)) - return(fixup_unknown_op(code, f, hop + OP_SAFE_CLOSURE_STAR_FX_1)); - } + if (fxify_closure_star_g(sc, f, code)) return(goto_eval); break; case T_GOTO: @@ -81649,13 +81797,13 @@ static goto_t op_unknown_a(s7_scheme *sc, s7_pointer f) if (!f) /* can be NULL if unbound variable */ return(unknown_unknown(sc)); #if SHOW_EVAL_OPS - fprintf(stderr, "%s %s\n", __func__, DISPLAY(f)); + fprintf(stderr, "%s %s\n", __func__, display(f)); #endif code = sc->code; #if S7_DEBUGGING if (!has_fx(cdr(code))) - fprintf(stderr, "op_unknown_a missing _a support? %s\n", DISPLAY_80(code)); + fprintf(stderr, "op_unknown_a missing _a support? %s\n", display_80(code)); #endif switch (type(f)) @@ -81684,27 +81832,7 @@ static goto_t op_unknown_a(s7_scheme *sc, s7_pointer f) safe_case = is_safe_closure(f); one_form = is_null(cdr(body)); if (is_immutable_and_stable(sc, car(code))) hop = 1; - - if (one_form) - { - if (safe_case) - { - if (is_fxable(sc, car(body))) - { - annotate_arg(sc, body, sc->envir); - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_A_A); - set_closure_has_fx(f); - fx_tree(sc, body, car(closure_args(f)), NULL); - } - else - { - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_A_P); - closure_clear_multiform(f); - } - } - else set_optimize_op(code, hop + OP_CLOSURE_A_P); - } - else set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_A : OP_CLOSURE_A)); + fxify_closure_a(sc, f, one_form, safe_case, hop, code, sc->envir); /* we might not be in "f" I think, tree_memq(sc, code, body)?? */ if ((safe_case) && @@ -81719,20 +81847,7 @@ static goto_t op_unknown_a(s7_scheme *sc, s7_pointer f) break; case T_CLOSURE_STAR: - if ((!has_methods(f)) && - (closure_star_arity_to_int(sc, f) != 0)) - { - int32_t hop = 0; - if (is_immutable_and_stable(sc, car(code))) hop = 1; - if (lambda_has_simple_defaults(closure_body(f))) - { - if (arglist_has_rest(sc, closure_args(f))) - return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_FX_1 : OP_CLOSURE_STAR_FX))); - return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A))); - } - if (is_safe_closure(f)) - return(fixup_unknown_op(code, f, hop + OP_SAFE_CLOSURE_STAR_FX_1)); - } + if (fxify_closure_star_g(sc, f, code)) return(goto_eval); break; case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: @@ -81778,15 +81893,29 @@ static goto_t fixup_closure_star_aa(s7_scheme *sc, s7_pointer f, s7_pointer code if (!has_methods(f)) { int32_t hop = 0; + int32_t arity; + bool safe_case; + s7_pointer arg1, par1; + + safe_case = is_safe_closure(f); + arity = closure_star_arity_to_int(sc, f); + arg1 = cadr(code); + par1 = car(closure_args(f)); + if (is_pair(par1)) par1 = car(par1); + if (is_immutable_and_stable(sc, car(code))) hop = 1; set_opt3_arglen(code, small_int(2)); - if (lambda_has_simple_defaults(closure_body(f))) + + if ((arity == 1) && (is_keyword(arg1)) && (keyword_symbol(arg1) == par1)) + return(fixup_unknown_op(code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_KA : OP_CLOSURE_STAR_KA))); + + if (lambda_has_simple_defaults(f)) { - if (closure_star_arity_to_int(sc, f) == 2) - return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_AA : OP_CLOSURE_STAR_FX))); - return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_FX_2 : OP_CLOSURE_STAR_FX))); + if (arity == 2) + return(fixup_unknown_op(code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_AA : OP_CLOSURE_STAR_FX))); + return(fixup_unknown_op(code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_FX_2 : OP_CLOSURE_STAR_FX))); } - if (is_safe_closure(f)) + if (safe_case) return(fixup_unknown_op(code, f, hop + OP_SAFE_CLOSURE_STAR_FX_2)); } return(fixup_unknown_op(code, f, OP_S_AA)); @@ -81799,13 +81928,13 @@ static goto_t op_unknown_gg(s7_scheme *sc, s7_pointer f) if (!f) /* can be NULL if unbound variable */ return(unknown_unknown(sc)); #if SHOW_EVAL_OPS - fprintf(stderr, "%s %s\n", __func__, DISPLAY(f)); + fprintf(stderr, "%s %s\n", __func__, display(f)); #endif code = sc->code; #if S7_DEBUGGING if ((is_pair(cadr(code))) || (is_pair(caddr(code)))) - fprintf(stderr, "%s[%d]: arg is a pair: %s\n", __func__, __LINE__, DISPLAY(code)); + fprintf(stderr, "%s[%d]: arg is a pair: %s\n", __func__, __LINE__, display(code)); #endif s1 = is_normal_symbol(cadr(code)); s2 = is_normal_symbol(caddr(code)); @@ -81955,7 +82084,7 @@ static goto_t op_unknown_all_s(s7_scheme *sc, s7_pointer f) if (!f) /* can be NULL if unbound variable */ return(unknown_unknown(sc)); #if SHOW_EVAL_OPS - fprintf(stderr, "%s %s\n", __func__, DISPLAY(f)); + fprintf(stderr, "%s %s\n", __func__, display(f)); #endif code = sc->code; @@ -82010,7 +82139,7 @@ static goto_t op_unknown_all_s(s7_scheme *sc, s7_pointer f) case T_CLOSURE_STAR: if ((!has_methods(f)) && - (lambda_has_simple_defaults(closure_body(f))) && + (lambda_has_simple_defaults(f)) && ((closure_star_arity_to_int(sc, f) < 0) || ((closure_star_arity_to_int(sc, f) * 2) >= num_args))) { int32_t hop = 0; @@ -82039,7 +82168,7 @@ static goto_t op_unknown_aa(s7_scheme *sc, s7_pointer f) if (!f) /* can be NULL if unbound variable */ return(unknown_unknown(sc)); #if SHOW_EVAL_OPS - fprintf(stderr, "%s %s\n", __func__, DISPLAY(f)); + fprintf(stderr, "%s %s\n", __func__, display(f)); #endif code = sc->code; @@ -82122,7 +82251,7 @@ static goto_t op_unknown_fx(s7_scheme *sc, s7_pointer f) if (!f) /* can be NULL if unbound variable */ return(unknown_unknown(sc)); #if SHOW_EVAL_OPS - fprintf(stderr, "%s %s\n", __func__, DISPLAY(f)); + fprintf(stderr, "%s %s\n", __func__, display(f)); #endif code = sc->code; @@ -82168,7 +82297,7 @@ static goto_t op_unknown_fx(s7_scheme *sc, s7_pointer f) case T_CLOSURE_STAR: if ((!has_methods(f)) && - (lambda_has_simple_defaults(closure_body(f))) && + (lambda_has_simple_defaults(f)) && ((closure_star_arity_to_int(sc, f) < 0) || ((closure_star_arity_to_int(sc, f) * 2) >= num_args))) { int32_t hop = 0; @@ -82434,7 +82563,7 @@ static bool op_implicit_vector_set_4(s7_scheme *sc) return(false); } -static void op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ctr 1)) */ +static inline void op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ctr 1)) */ { s7_pointer val, y; @@ -82591,7 +82720,7 @@ static void apply_c_macro(s7_scheme *sc) /* -------- C-bas if (is_multiple_value(sc->code)) /* can this happen? s7_values splices before returning, and `(values ...) is handled later */ { #if S7_DEBUGGING - fprintf(stderr, "%d unexpected mv code: %s\n", __LINE__, DISPLAY(sc->code)); + fprintf(stderr, "%d unexpected mv code: %s\n", __LINE__, display(sc->code)); #endif push_stack(sc, OP_EVAL_MACRO_MV, sc->nil, cdr(sc->code)); sc->code = car(sc->code); @@ -82988,7 +83117,7 @@ static inline goto_t lambda_star_default(s7_scheme *sc) } else { - push_stack(sc, OP_LAMBDA_STAR_DEFAULT, sc->args, sc->code); + push_stack_direct(sc, OP_LAMBDA_STAR_DEFAULT, sc->args, sc->code); sc->code = val; return(goto_eval); } @@ -83024,7 +83153,7 @@ static inline bool set_star_args(s7_scheme *sc, s7_pointer top) if (is_slot(sc->args)) { /* get default values, which may involve evaluation -- see also OP_LAMBDA_STAR_DEFAULT */ - push_stack(sc, OP_GC_PROTECT, sc->args, sc->code); + push_stack_direct(sc, OP_GC_PROTECT, sc->args, sc->code); if (lambda_star_default(sc) == goto_eval) return(true); /* else fall_through */ pop_stack_no_op(sc); /* get original args and code back */ } @@ -83035,7 +83164,7 @@ static inline bool set_star_args(s7_scheme *sc, s7_pointer top) static bool apply_safe_closure_star_1(s7_scheme *sc) /* -------- define* (lambda*) -------- */ { s7_pointer z; - /* fprintf(stderr, "%s %s\n", __func__, DISPLAY(sc->code)); */ + /* fprintf(stderr, "%s %s\n", __func__, display(sc->code)); */ /* slots are in "reverse order" -- in the same order as the args, despite let printout (which reverses the order!) */ sc->envir = closure_let(sc->code); @@ -83063,7 +83192,7 @@ static bool apply_safe_closure_star_1(s7_scheme *sc) /* ------ static bool apply_unsafe_closure_star_1(s7_scheme *sc) { s7_pointer z, car_z, val, top; - /* fprintf(stderr, "%s %s\n", __func__, DISPLAY(sc->code)); */ + /* fprintf(stderr, "%s %s\n", __func__, display(sc->code)); */ top = sc->nil; for (z = closure_args(sc->code); is_pair(z); z = cdr(z)) { @@ -83178,9 +83307,13 @@ static bool apply_closure_star(s7_scheme *sc) return(apply_unsafe_closure_star_1(sc)); } -static void safe_closure_star_a(s7_scheme *sc, s7_pointer code) +#if WITH_GCC +static inline s7_pointer safe_closure_star_a1(s7_scheme *sc, s7_pointer code) __attribute__((always_inline)); +#endif + +static inline s7_pointer safe_closure_star_a1(s7_scheme *sc, s7_pointer code) { - s7_pointer p, val, func; + s7_pointer val, func; func = opt1_lambda(code); val = fx_call(sc, cdr(code)); if ((is_keyword(val)) && @@ -83189,8 +83322,14 @@ static void safe_closure_star_a(s7_scheme *sc, s7_pointer code) set_elist_4(sc, wrap_string(sc, "~A: keyword argument's value is missing: ~S in ~S", 49), closure_name(sc, func), val, sc->args)); sc->envir = old_frame_with_slot(sc, closure_let(func), val); - /* that sets the first arg to the passed symbol value; now set default values, if any */ + sc->code = T_Pair(closure_body(func)); + return(func); +} +static void safe_closure_star_a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer p, func; + func = safe_closure_star_a1(sc, code); p = cdr(closure_args(func)); if (is_pair(p)) { @@ -83209,32 +83348,39 @@ static void safe_closure_star_a(s7_scheme *sc, s7_pointer code) symbol_set_local(slot_symbol(x), let_id(sc->envir), x); } } +} + +static void safe_closure_star_ka(s7_scheme *sc, s7_pointer code) +{ + s7_pointer func; + /* two args, but k=arg key, key has been checked. no trailing pars */ + func = opt1_lambda(code); + sc->envir = old_frame_with_slot(sc, closure_let(func), fx_call(sc, cddr(code))); sc->code = T_Pair(closure_body(func)); } static void safe_closure_star_aa(s7_scheme *sc, s7_pointer code) { /* here closure_arity == 2 and we have 2 args */ - s7_pointer arg1, arg2, clet, p; + s7_pointer arg1, arg2, func; - clet = closure_let(opt1_lambda(code)); - p = cdr(code); - arg1 = fx_call(sc, p); - arg2 = fx_call(sc, cdr(p)); + func = opt1_lambda(code); + arg1 = fx_call(sc, cdr(code)); + arg2 = fx_call(sc, cddr(code)); if (is_keyword(arg1)) { - if (keyword_symbol(arg1) == slot_symbol(let_slots(clet))) + if (keyword_symbol(arg1) == slot_symbol(let_slots(closure_let(func)))) { arg1 = arg2; - arg2 = cadr(closure_args(opt1_lambda(code))); + arg2 = cadr(closure_args(func)); if (is_pair(arg2)) arg2 = (is_pair(cadr(arg2))) ? cadadr(arg2) : cadr(arg2); else arg2 = sc->F; } else { - if (keyword_symbol(arg1) == slot_symbol(next_slot(let_slots(clet)))) + if (keyword_symbol(arg1) == slot_symbol(next_slot(let_slots(closure_let(func))))) { - arg1 = car(closure_args(opt1_lambda(code))); + arg1 = car(closure_args(func)); if (is_pair(arg1)) arg1 = (is_pair(cadr(arg1))) ? cadadr(arg1) : cadr(arg1); else arg1 = sc->F; } else @@ -83242,7 +83388,7 @@ static void safe_closure_star_aa(s7_scheme *sc, s7_pointer code) if (!sc->accept_all_keyword_arguments) s7_error(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, wrap_string(sc, "~A: unknown keyword argument: ~S in ~S", 38), - closure_name(sc, opt1_lambda(code)), arg1, code)); + closure_name(sc, func), arg1, code)); /* arg1 is already the value */ } } @@ -83253,10 +83399,10 @@ static void safe_closure_star_aa(s7_scheme *sc, s7_pointer code) (!sc->accept_all_keyword_arguments)) s7_error(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, wrap_string(sc, "~A: keyword argument's value is missing: ~S in ~S", 49), - closure_name(sc, opt1_lambda(code)), arg2, code)); + closure_name(sc, func), arg2, code)); } - sc->envir = old_frame_with_two_slots(sc, clet, arg1, arg2); - sc->code = T_Pair(closure_body(opt1_lambda(code))); + sc->envir = old_frame_with_two_slots(sc, closure_let(func), arg1, arg2); + sc->code = T_Pair(closure_body(func)); } static bool safe_closure_star_fx_0(s7_scheme *sc, s7_pointer code) @@ -83275,7 +83421,7 @@ static bool safe_closure_star_fx_1(s7_scheme *sc, s7_pointer code) sc->args = safe_list_1(sc); arglist = sc->args; set_car(sc->args, fx_call(sc, cdr(code))); - call_lambda_star(sc); /* this clears list_in_use */ + call_lambda_star(sc); /* this clears list_in_use, sets target */ sc->args = sc->nil; return(target); } @@ -83320,6 +83466,16 @@ static bool safe_closure_star_fx(s7_scheme *sc, s7_pointer code) return(target); } +static void closure_star_ka(s7_scheme *sc, s7_pointer code) +{ + s7_pointer val, p, func; + val = fx_call(sc, cddr(code)); + func = opt1_lambda(code); + p = car(closure_args(func)); + new_frame_with_slot(sc, closure_let(func), sc->envir, (is_pair(p)) ? car(p) : p, val); + sc->code = T_Pair(closure_body(func)); +} + static void closure_star_a(s7_scheme *sc, s7_pointer code) { s7_pointer val, p, func; @@ -83747,7 +83903,7 @@ static void op_closure_c_p(s7_scheme *sc) static void op_safe_closure_p(s7_scheme *sc) { - push_stack(sc, OP_SAFE_CLOSURE_P_1, sc->args, sc->code); + push_stack_direct(sc, OP_SAFE_CLOSURE_P_1, sc->args, sc->code); sc->code = cadr(sc->code); } @@ -83795,7 +83951,7 @@ static void op_safe_closure_saa(s7_scheme *sc) static void op_closure_p(s7_scheme *sc) { - push_stack(sc, OP_CLOSURE_P_1, sc->args, sc->code); + push_stack_direct(sc, OP_CLOSURE_P_1, sc->args, sc->code); sc->code = cadr(sc->code); } @@ -83807,12 +83963,6 @@ static void op_closure_p_1(s7_scheme *sc) sc->code = T_Pair(closure_body(sc->code)); } -static void op_closure_p_mv(s7_scheme *sc) -{ - sc->code = opt1_lambda(sc->code); - sc->args = copy_list(sc, sc->value); -} - static void op_safe_closure_c(s7_scheme *sc) { sc->value = cadr(sc->code); @@ -83878,12 +84028,6 @@ static void op_closure_ap_1(s7_scheme *sc) sc->code = T_Pair(closure_body(sc->code)); } -static void op_closure_ap_mv(s7_scheme *sc) -{ - sc->code = opt1_lambda(sc->code); - sc->args = cons(sc, sc->args, copy_list(sc, sc->value)); -} - static void op_closure_pa(s7_scheme *sc) { s7_pointer val, code; @@ -83901,12 +84045,6 @@ static void op_closure_pa_1(s7_scheme *sc) sc->code = T_Pair(closure_body(sc->code)); } -static void op_closure_pa_mv(s7_scheme *sc) -{ - sc->code = opt1_lambda(sc->code); - sc->args = s7_append(sc, sc->value, cons(sc, sc->args, sc->nil)); /* copy_list until 8-Aug-19 */ -} - static void op_safe_closure_ap(s7_scheme *sc) { s7_pointer val; @@ -83935,6 +84073,137 @@ static void op_safe_closure_pa_1(s7_scheme *sc) sc->code = T_Pair(closure_body(opt1_lambda(sc->code))); } +static void op_safe_closure_pp(s7_scheme *sc) +{ + push_stack_no_args_direct(sc, OP_SAFE_CLOSURE_PP_1, sc->code); + sc->code = cadr(sc->code); +} + +static void op_safe_closure_pp_1(s7_scheme *sc) +{ + push_stack(sc, OP_SAFE_CLOSURE_AP_1, sc->value, sc->code); + sc->code = caddr(sc->code); +} + +static void op_closure_pp(s7_scheme *sc) +{ + push_stack_no_args_direct(sc, OP_CLOSURE_PP_1, sc->code); + sc->code = cadr(sc->code); +} + +static void op_closure_pp_1(s7_scheme *sc) +{ + push_stack(sc, OP_CLOSURE_AP_1, sc->value, sc->code); + sc->code = caddr(sc->code); +} + +static void new_frame_with_three_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3) +{ + s7_pointer last_slot; + /* may need gc protection here */ + new_frame_with_two_slots(sc, closure_let(func), sc->envir, car(closure_args(func)), val1, cadr(closure_args(func)), val2); + last_slot = next_slot(let_slots(sc->envir)); + add_slot_at_end(let_id(sc->envir), last_slot, caddr(closure_args(func)), val3); +} + +static void op_safe_or_unsafe_closure_3p(s7_scheme *sc) +{ + s7_pointer p, form, val; + form = sc->code; + p = cdr(sc->code); + if (has_fx(p)) + { + sc->value = fx_call(sc, p); + p = cdr(p); + if (has_fx(p)) + { + s7_pointer old_val; + old_val = sc->value; + val = cons(sc, old_val, fx_call(sc, p)); + push_stack(sc, OP_SAFE_OR_UNSAFE_CLOSURE_3P_3, val, form); + sc->code = cadr(p); + } + else + { + push_stack(sc, OP_SAFE_OR_UNSAFE_CLOSURE_3P_2, sc->value, form); + sc->code = car(p); + } + } + else + { + push_stack_no_args(sc, OP_SAFE_OR_UNSAFE_CLOSURE_3P_1, form); + sc->code = car(p); + } +} + +static bool op_safe_or_unsafe_closure_3p_1(s7_scheme *sc) +{ + s7_pointer p, val, form; + form = sc->code; + val = sc->value; /* can be clobbered by fx_call */ + p = cddr(sc->code); + if (has_fx(p)) + { + if (has_fx(cdr(p))) + { + s7_pointer func, arg1, arg2; + arg1 = fx_call(sc, p); + sc->args = arg1; + arg2 = fx_call(sc, cdr(p)); + func = opt1_lambda(sc->code); + if (is_safe_closure(func)) + sc->envir = old_frame_with_three_slots(sc, closure_let(func), val, arg1, arg2); + else new_frame_with_three_slots(sc, func, val, arg1, arg2); + sc->code = T_Pair(closure_body(func)); + return(true); + } + val = cons(sc, val, fx_call(sc, p)); + push_stack(sc, OP_SAFE_OR_UNSAFE_CLOSURE_3P_3, val, form); + sc->code = cadr(p); + } + else + { + push_stack(sc, OP_SAFE_OR_UNSAFE_CLOSURE_3P_2, val, form); + sc->code = car(p); + } + return(false); +} + +static bool op_safe_or_unsafe_closure_3p_2(s7_scheme *sc) +{ + s7_pointer p, val, arg, form; + form = sc->code; + val = sc->value; + arg = sc->args; + p = cdddr(sc->code); + if (has_fx(p)) + { + s7_pointer func, arg1; + arg1 = fx_call(sc, p); + sc->args = arg1; + func = opt1_lambda(sc->code); + if (is_safe_closure(func)) + sc->envir = old_frame_with_three_slots(sc, closure_let(func), arg, val, arg1); + else new_frame_with_three_slots(sc, func, arg, val, arg1); + sc->code = T_Pair(closure_body(func)); + return(true); + } + val = cons(sc, arg, val); + push_stack(sc, OP_SAFE_OR_UNSAFE_CLOSURE_3P_3, val, form); + sc->code = car(p); + return(false); +} + +static void op_safe_or_unsafe_closure_3p_3(s7_scheme *sc) +{ + s7_pointer func; + func = opt1_lambda(sc->code); + if (is_safe_closure(func)) + sc->envir = old_frame_with_three_slots(sc, closure_let(func), car(sc->args), cdr(sc->args), sc->value); + else new_frame_with_three_slots(sc, func, car(sc->args), cdr(sc->args), sc->value); + sc->code = T_Pair(closure_body(func)); +} + static void op_safe_closure_sa(s7_scheme *sc) { s7_pointer f, args; @@ -84040,7 +84309,7 @@ static void op_closure_cs(s7_scheme *sc) sc->code = T_Pair(closure_body(sc->code)); } -static void op_closure_3s(s7_scheme *sc) +static void op_closure_3s(s7_scheme *sc) /* inline here (and always_inline) makes gcc unhappy elsewhere */ { s7_pointer e, p, args, last_slot; s7_int id; @@ -84467,6 +84736,37 @@ static s7_pointer fx_tc_or_a_and_a_la(s7_scheme *sc, s7_pointer arg) return(sc->value); } +static void op_tc_and_a_or_a_a_la(s7_scheme *sc, s7_pointer code) +{ + s7_pointer fx_and, fx_or1, fx_or2, fx_la, la_slot; + + fx_and = cdr(code); /* first clause of and */ + fx_or1 = cdadr(fx_and); + fx_or2 = cdr(fx_or1); + fx_la = cdadr(fx_or2); + la_slot = let_slots(sc->envir); + while (true) + { + s7_pointer p; + p = fx_call(sc, fx_and); + if (p == sc->F) {sc->value = p; return;} + p = fx_call(sc, fx_or1); + if (p != sc->F) {sc->value = p; return;} + p = fx_call(sc, fx_or2); + if (p != sc->F) {sc->value = p; return;} + slot_set_value(la_slot, fx_call(sc, fx_la)); + } +} + +static s7_pointer fx_tc_and_a_or_a_a_la(s7_scheme *sc, s7_pointer arg) +{ +#if S7_DEBUGGING + tc_rec_calls[OP_TC_AND_A_OR_A_A_LA]++; +#endif + op_tc_and_a_or_a_a_la(sc, arg); + return(sc->value); +} + static void op_tc_or_a_a_and_a_a_la(s7_scheme *sc, s7_pointer code) { s7_pointer fx_and1, fx_and2, fx_or1, fx_or2, fx_la, la_slot; @@ -84520,8 +84820,9 @@ static void op_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer code) if (p == sc->F) {sc->value = p; return;} p = fx_call(sc, fx_or); if (p != sc->F) {sc->value = p; return;} - slot_set_value(la_slot, fx_call(sc, fx_la)); + sc->rec_p1 = fx_call(sc, fx_la); slot_set_value(laa_slot, fx_call(sc, fx_laa)); + slot_set_value(la_slot, sc->rec_p1); } } @@ -84531,6 +84832,7 @@ static s7_pointer fx_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer arg) tc_rec_calls[OP_TC_AND_A_OR_A_LAA]++; #endif op_tc_and_a_or_a_laa(sc, arg); + sc->rec_p1 = sc->F; return(sc->value); } @@ -84552,8 +84854,9 @@ static void op_tc_or_a_and_a_laa(s7_scheme *sc, s7_pointer code) if (p != sc->F) {sc->value = p; return;} p = fx_call(sc, fx_and); if (p == sc->F) {sc->value = p; return;} - slot_set_value(la_slot, fx_call(sc, fx_la)); + sc->rec_p1 = fx_call(sc, fx_la); slot_set_value(laa_slot, fx_call(sc, fx_laa)); + slot_set_value(la_slot, sc->rec_p1); } } @@ -84563,6 +84866,7 @@ static s7_pointer fx_tc_or_a_and_a_laa(s7_scheme *sc, s7_pointer arg) tc_rec_calls[OP_TC_OR_A_AND_A_LAA]++; #endif op_tc_or_a_and_a_laa(sc, arg); + sc->rec_p1 = sc->F; return(sc->value); } @@ -84589,9 +84893,11 @@ static void op_tc_or_a_and_a_a_l3a(s7_scheme *sc, bool or_case, s7_pointer code) if (p == sc->F) {sc->value = p; return;} p = fx_call(sc, fx_and2); if (p == sc->F) {sc->value = p; return;} - slot_set_value(la_slot, fx_call(sc, fx_la)); - slot_set_value(laa_slot, fx_call(sc, fx_laa)); + sc->rec_p1 = fx_call(sc, fx_la); + sc->rec_p2 = fx_call(sc, fx_laa); slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); + slot_set_value(la_slot, sc->rec_p1); + slot_set_value(laa_slot, sc->rec_p2); } } @@ -84601,6 +84907,8 @@ static s7_pointer fx_tc_or_a_and_a_a_l3a(s7_scheme *sc, s7_pointer arg) tc_rec_calls[OP_TC_OR_A_AND_A_A_L3A]++; #endif op_tc_or_a_and_a_a_l3a(sc, true, arg); + sc->rec_p1 = sc->F; + sc->rec_p2 = sc->F; return(sc->value); } @@ -84610,6 +84918,8 @@ static s7_pointer fx_tc_if_a_t_and_a_a_l3a(s7_scheme *sc, s7_pointer arg) tc_rec_calls[OP_TC_OR_A_AND_A_A_L3A]++; #endif op_tc_or_a_and_a_a_l3a(sc, false, arg); + sc->rec_p1 = sc->F; + sc->rec_p2 = sc->F; return(sc->value); } @@ -84624,7 +84934,6 @@ static bool op_tc_if_a_z_la(s7_scheme *sc, s7_pointer code) if (is_t_integer(slot_value(la_slot))) { sc->pc = 0; - reset_opts(sc); if (bool_optimize(sc, if_test)) { opt_info *o, *o1; @@ -84636,9 +84945,7 @@ static bool op_tc_if_a_z_la(s7_scheme *sc, s7_pointer code) slot_set_value(la_slot, val = make_mutable_integer(sc, integer(slot_value(la_slot)))); while (true) { - sc->pc = 0; if (o->v[0].fb(o)) break; - sc->pc++; integer(val) = o1->v[0].fi(o1); } return(op_tc_z(sc, if_true)); @@ -84673,7 +84980,6 @@ static bool op_tc_if_a_la_z(s7_scheme *sc, s7_pointer code) if (is_t_integer(slot_value(la_slot))) { sc->pc = 0; - reset_opts(sc); if (bool_optimize(sc, if_test)) { opt_info *o, *o1; @@ -84685,12 +84991,8 @@ static bool op_tc_if_a_la_z(s7_scheme *sc, s7_pointer code) slot_set_value(la_slot, val = make_mutable_integer(sc, integer(slot_value(la_slot)))); while (true) { - sc->pc = 0; if (o->v[0].fb(o)) - { - sc->pc++; - integer(val) = o1->v[0].fi(o1); - } + integer(val) = o1->v[0].fi(o1); else break; } return(op_tc_z(sc, if_false)); @@ -84715,13 +85017,13 @@ static s7_pointer fx_tc_if_a_la_z(s7_scheme *sc, s7_pointer arg) return(sc->value); } -static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code) +static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code, bool z_first) { - s7_pointer if_test, if_true, la, laa, la_slot, laa_slot; + s7_pointer if_test, if_z, la, laa, la_slot, laa_slot; s7_function tf; if_test = cdr(code); - if_true = cdr(if_test); - la = cdadr(if_true); + if_z = (z_first) ? cdr(if_test) : cddr(if_test); + la = (z_first) ? cdaddr(if_test) : cdadr(if_test); laa = cdr(la); la_slot = let_slots(sc->envir); laa_slot = next_slot(la_slot); @@ -84729,7 +85031,6 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code) if (!no_bool_opt(code)) { sc->pc = 0; - reset_opts(sc); if (bool_optimize(sc, if_test)) { opt_info *o, *o1, *o2; @@ -84756,7 +85057,7 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code) fb = o->v[0].fb; fi1 = o1->v[0].fi; fi2 = o2->v[0].fi; - while (!fb(o)) + while (fb(o) != z_first) { s7_int i1; i1 = fi1(o1); @@ -84772,7 +85073,7 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code) fb = o->v[0].fb; fd1 = o1->v[0].fd; fd2 = o2->v[0].fd; - while (!fb(o)) + while (fb(o) != z_first) { s7_double x1; x1 = fd1(o1); @@ -84780,7 +85081,7 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code) real(val1) = x1; } } - return(op_tc_z(sc, if_true)); + return(op_tc_z(sc, if_z)); } } } @@ -84802,7 +85103,7 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code) while (true) { s7_double x1; - if (o->v[0].fb(o)) break; + if (o->v[0].fb(o) == z_first) break; x1 = o1->v[0].fd(o1); real(val2) = o2->v[0].fd(o2); real(val1) = x1; @@ -84813,33 +85114,40 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code) while (true) { s7_double x1; - sc->pc = 0; - if (o->v[0].fb(o)) break; - sc->pc++; + if (o->v[0].fb(o) == z_first) break; x1 = o1->v[0].fd(o1); - sc->pc++; real(val2) = o2->v[0].fd(o2); real(val1) = x1; } } - return(op_tc_z(sc, if_true)); + return(op_tc_z(sc, if_z)); } } } } - else set_no_bool_opt(code); + set_no_bool_opt(code); } tf = c_callee(if_test); if_test = car(if_test); - while (tf(sc, if_test) == sc->F) + if (z_first) { - s7_pointer a1; - a1 = fx_call(sc, la); - sc->w = a1; - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, a1); + while (tf(sc, if_test) == sc->F) + { + sc->rec_p1 = fx_call(sc, la); + slot_set_value(laa_slot, fx_call(sc, laa)); + slot_set_value(la_slot, sc->rec_p1); + } } - return(op_tc_z(sc, if_true)); + else + { + while (tf(sc, if_test) != sc->F) + { + sc->rec_p1 = fx_call(sc, la); + slot_set_value(laa_slot, fx_call(sc, laa)); + slot_set_value(la_slot, sc->rec_p1); + } + } + return(op_tc_z(sc, if_z)); } static s7_pointer fx_tc_if_a_z_laa(s7_scheme *sc, s7_pointer arg) @@ -84847,123 +85155,103 @@ static s7_pointer fx_tc_if_a_z_laa(s7_scheme *sc, s7_pointer arg) #if S7_DEBUGGING tc_rec_calls[OP_TC_IF_A_Z_LAA]++; #endif - op_tc_if_a_z_laa(sc, arg); + op_tc_if_a_z_laa(sc, arg, true); + sc->rec_p1 = sc->F; return(sc->value); } -static bool op_tc_if_a_laa_z(s7_scheme *sc, s7_pointer code) +static s7_pointer fx_tc_if_a_laa_z(s7_scheme *sc, s7_pointer arg) { - s7_pointer if_test, if_false, la, laa, la_slot, laa_slot; +#if S7_DEBUGGING + tc_rec_calls[OP_TC_IF_A_LAA_Z]++; +#endif + op_tc_if_a_z_laa(sc, arg, false); + sc->rec_p1 = sc->F; + return(sc->value); +} + +static bool op_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer code, bool z_first) +{ + s7_pointer if_test, f_z, la, laa, l3a, la_slot, laa_slot, l3a_slot; + s7_function tf; if_test = cdr(code); - if_false = cddr(if_test); - la = cdadr(if_test); + f_z = (z_first) ? cdr(if_test) : cddr(if_test); + la = (z_first) ? cdaddr(if_test) : cdadr(if_test); laa = cdr(la); + l3a = cdr(laa); la_slot = let_slots(sc->envir); laa_slot = next_slot(la_slot); - - if (!no_bool_opt(code)) + l3a_slot = next_slot(laa_slot); + tf = c_callee(if_test); + if_test = car(if_test); + if (z_first) { - sc->pc = 0; - reset_opts(sc); - if (bool_optimize(sc, if_test)) + while (tf(sc, if_test) == sc->F) { - opt_info *o, *o1, *o2; - int32_t start_pc; - o = sc->opts[0]; - start_pc = sc->pc; - o1 = sc->opts[sc->pc]; - if ((is_t_integer(slot_value(la_slot))) && - (is_t_integer(slot_value(laa_slot)))) - { - if (int_optimize(sc, la)) - { - o2 = sc->opts[sc->pc]; - if (int_optimize(sc, laa)) - { - s7_pointer val1, val2; - slot_set_value(la_slot, val1 = make_mutable_integer(sc, integer(slot_value(la_slot)))); - slot_set_value(laa_slot, val2 = make_mutable_integer(sc, integer(slot_value(laa_slot)))); - while (true) - { - sc->pc = 0; - if (o->v[0].fb(o)) - { - s7_int i1; - sc->pc++; - i1 = o1->v[0].fi(o1); - sc->pc++; - integer(val2) = o2->v[0].fi(o2); - integer(val1) = i1; - } - else break; - } - return(op_tc_z(sc, if_false)); - } - } - } - if ((is_float(slot_value(la_slot))) && - (is_float(slot_value(laa_slot)))) - { - sc->pc = start_pc; - if (float_optimize(sc, la)) - { - o2 = sc->opts[sc->pc]; - if (float_optimize(sc, laa)) - { - s7_pointer val1, val2; - slot_set_value(la_slot, val1 = s7_make_mutable_real(sc, real(slot_value(la_slot)))); - slot_set_value(laa_slot, val2 = s7_make_mutable_real(sc, real(slot_value(laa_slot)))); - while (true) - { - sc->pc = 0; - if (o->v[0].fb(o)) - { - s7_double x1; - sc->pc++; - x1 = o1->v[0].fd(o1); - sc->pc++; - real(val2) = o2->v[0].fd(o2); - real(val1) = x1; - } - else break; - } - return(op_tc_z(sc, if_false)); - } - } - } + sc->rec_p1 = fx_call(sc, la); + sc->rec_p2 = fx_call(sc, laa); + slot_set_value(l3a_slot, fx_call(sc, l3a)); + slot_set_value(laa_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); } - else set_no_bool_opt(code); } - while (true) + else { - s7_pointer a1; - if (fx_call(sc, if_test) == sc->F) break; - a1 = fx_call(sc, la); - sc->w = a1; - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, a1); + while (tf(sc, if_test) != sc->F) + { + sc->rec_p1 = fx_call(sc, la); + sc->rec_p2 = fx_call(sc, laa); + slot_set_value(l3a_slot, fx_call(sc, l3a)); + slot_set_value(laa_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); + } } - return(op_tc_z(sc, if_false)); + return(op_tc_z(sc, f_z)); } -static s7_pointer fx_tc_if_a_laa_z(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer arg) { #if S7_DEBUGGING - tc_rec_calls[OP_TC_IF_A_LAA_Z]++; + tc_rec_calls[OP_TC_IF_A_Z_L3A]++; #endif - op_tc_if_a_laa_z(sc, arg); + op_tc_if_a_z_l3a(sc, arg, true); + sc->rec_p1 = sc->F; + sc->rec_p2 = sc->F; return(sc->value); } -static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code) +static s7_pointer fx_tc_if_a_l3a_z(s7_scheme *sc, s7_pointer arg) { - s7_pointer if_test, if_true, if_false, f_test, f_true, la, la_slot, endp; - if_test = cdr(code); - if_true = cdr(if_test); - if_false = cadr(if_true); - f_test = cdr(if_false); - f_true = cdr(f_test); - la = cdadr(f_true); +#if S7_DEBUGGING + tc_rec_calls[OP_TC_IF_A_L3A_Z]++; +#endif + op_tc_if_a_z_l3a(sc, arg, false); + sc->rec_p1 = sc->F; + sc->rec_p2 = sc->F; + return(sc->value); +} + +static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code, bool z_first, bool cond) +{ + s7_pointer if_test, if_true, if_false, f_test, f_z, la, la_slot, endp; + if (!cond) + { + if_test = cdr(code); + if_true = cdr(if_test); + if_false = cadr(if_true); + f_test = cdr(if_false); + f_z = (z_first) ? cdr(f_test) : cddr(f_test); + la = (z_first) ? cdaddr(f_test) : cdadr(f_test); + } + else + { + if_test = cadr(code); + if_true = cdr(if_test); + if_false = caddr(code); + f_test = if_false; + f_z = cdr(f_test); + la = cdadr(cadddr(code)); + } la_slot = let_slots(sc->envir); if (is_t_integer(slot_value(la_slot))) @@ -84985,20 +85273,29 @@ static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code) slot_set_value(la_slot, val = make_mutable_integer(sc, integer(slot_value(la_slot)))); while (true) { - sc->pc = 0; if (o->v[0].fb(o)) {endp = if_true; break;} - sc->pc++; - if (o1->v[0].fb(o1)) {endp = f_true; break;} - sc->pc++; + if (o1->v[0].fb(o1) == z_first) {endp = f_z; break;} integer(val) = o2->v[0].fi(o2); } return(op_tc_z(sc, endp)); }}}} - while (true) + if (z_first) { - if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;} - if (fx_call(sc, f_test) != sc->F) {endp = f_true; break;} - slot_set_value(la_slot, fx_call(sc, la)); + while (true) + { + if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;} + if (fx_call(sc, f_test) != sc->F) {endp = f_z; break;} + slot_set_value(la_slot, fx_call(sc, la)); + } + } + else + { + while (true) + { + if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;} + if (fx_call(sc, f_test) == sc->F) {endp = f_z; break;} + slot_set_value(la_slot, fx_call(sc, la)); + } } return(op_tc_z(sc, endp)); } @@ -85008,69 +85305,25 @@ static s7_pointer fx_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer arg) #if S7_DEBUGGING tc_rec_calls[OP_TC_IF_A_Z_IF_A_Z_LA]++; #endif - op_tc_if_a_z_if_a_z_la(sc, arg); + op_tc_if_a_z_if_a_z_la(sc, arg, true, false); return(sc->value); } -static bool op_tc_if_a_z_if_a_la_z(s7_scheme *sc, s7_pointer code) +static s7_pointer fx_tc_if_a_z_if_a_la_z(s7_scheme *sc, s7_pointer arg) { - s7_pointer if_test, if_true, if_false, f_test, f_true, f_false, la, la_slot, endp; - if_test = cdr(code); - if_true = cdr(if_test); - if_false = cadr(if_true); - f_test = cdr(if_false); - f_true = cdr(f_test); - f_false = cdr(f_true); - la = cdar(f_true); - la_slot = let_slots(sc->envir); - - if (is_t_integer(slot_value(la_slot))) - { - opt_info *o; - sc->pc = 0; - o = sc->opts[0]; - if (bool_optimize_nw(sc, if_test)) - { - opt_info *o1; - o1 = sc->opts[sc->pc]; - if (bool_optimize_nw(sc, f_test)) - { - opt_info *o2; - o2 = sc->opts[sc->pc]; - if (int_optimize(sc, la)) - { - s7_pointer val; - slot_set_value(la_slot, val = make_mutable_integer(sc, integer(slot_value(la_slot)))); - while (true) - { - sc->pc = 0; - if (o->v[0].fb(o)) {endp = if_true; break;} - sc->pc++; - if (o1->v[0].fb(o1)) - { - sc->pc++; - integer(val) = o2->v[0].fi(o2); - } - else {endp = f_false; break;} - } - return(op_tc_z(sc, endp)); - }}}} - - while (true) - { - if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;} - if (fx_call(sc, f_test) == sc->F) {endp = f_false; break;} - slot_set_value(la_slot, fx_call(sc, la)); - } - return(op_tc_z(sc, endp)); +#if S7_DEBUGGING + tc_rec_calls[OP_TC_IF_A_Z_IF_A_LA_Z]++; +#endif + op_tc_if_a_z_if_a_z_la(sc, arg, false, false); + return(sc->value); } -static s7_pointer fx_tc_if_a_z_if_a_la_z(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_tc_cond_a_z_a_z_la(s7_scheme *sc, s7_pointer arg) { #if S7_DEBUGGING - tc_rec_calls[OP_TC_IF_A_Z_IF_A_LA_Z]++; + tc_rec_calls[OP_TC_COND_A_Z_A_Z_LA]++; #endif - op_tc_if_a_z_if_a_la_z(sc, arg); + op_tc_if_a_z_if_a_z_la(sc, arg, true, true); return(sc->value); } @@ -85089,13 +85342,11 @@ static bool op_tc_if_a_z_if_a_z_laa(s7_scheme *sc, bool cond, s7_pointer code) while (true) { - s7_pointer a1; if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;} if (fx_call(sc, f_test) != sc->F) {endp = f_true; break;} - a1 = fx_call(sc, la); - sc->w = a1; + sc->rec_p1 = fx_call(sc, la); slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, a1); + slot_set_value(la_slot, sc->rec_p1); } return(op_tc_z(sc, endp)); } @@ -85106,6 +85357,7 @@ static s7_pointer fx_tc_if_a_z_if_a_z_laa(s7_scheme *sc, s7_pointer arg) tc_rec_calls[OP_TC_IF_A_Z_IF_A_Z_LAA]++; #endif op_tc_if_a_z_if_a_z_laa(sc, false, arg); + sc->rec_p1 = sc->F; return(sc->value); } @@ -85115,6 +85367,7 @@ static s7_pointer fx_tc_cond_a_z_a_z_laa(s7_scheme *sc, s7_pointer arg) tc_rec_calls[OP_TC_COND_A_Z_A_Z_LAA]++; #endif op_tc_if_a_z_if_a_z_laa(sc, true, arg); + sc->rec_p1 = sc->F; return(sc->value); } @@ -85134,13 +85387,11 @@ static bool op_tc_if_a_z_if_a_laa_z(s7_scheme *sc, s7_pointer code) while (true) { - s7_pointer a1; if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;} if (fx_call(sc, f_test) == sc->F) {endp = f_false; break;} - a1 = fx_call(sc, la); - sc->w = a1; + sc->rec_p1 = fx_call(sc, la); slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, a1); + slot_set_value(la_slot, sc->rec_p1); } return(op_tc_z(sc, endp)); } @@ -85151,6 +85402,58 @@ static s7_pointer fx_tc_if_a_z_if_a_laa_z(s7_scheme *sc, s7_pointer arg) tc_rec_calls[OP_TC_IF_A_Z_IF_A_LAA_Z]++; #endif op_tc_if_a_z_if_a_laa_z(sc, arg); + sc->rec_p1 = sc->F; + return(sc->value); +} + +static bool op_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer if_test, if_true, if_false, f_test, f_true, f_false, la1, la2, la_slot, laa1, laa2, laa_slot, l3a1, l3a2, l3a_slot, endp; + if_test = cdr(code); + if_true = cdr(if_test); + if_false = cadr(if_true); + f_test = cdr(if_false); + f_true = cdr(f_test); + f_false = cdr(f_true); + la1 = cdar(f_true); + la2 = cdar(f_false); + la_slot = let_slots(sc->envir); + laa1 = cdr(la1); + laa2 = cdr(la2); + laa_slot = next_slot(la_slot); + l3a1 = cdr(laa1); + l3a2 = cdr(laa2); + l3a_slot = next_slot(laa_slot); + + while (true) + { + if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;} + if (fx_call(sc, f_test) != sc->F) + { + sc->rec_p1 = fx_call(sc, la1); + sc->rec_p2 = fx_call(sc, laa1); + slot_set_value(l3a_slot, fx_call(sc, l3a1)); + } + else + { + sc->rec_p1 = fx_call(sc, la2); + sc->rec_p2 = fx_call(sc, laa2); + slot_set_value(l3a_slot, fx_call(sc, l3a2)); + } + slot_set_value(laa_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); + } + return(op_tc_z(sc, endp)); +} + +static s7_pointer fx_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer arg) +{ +#if S7_DEBUGGING + tc_rec_calls[OP_TC_IF_A_Z_IF_A_L3A_L3A]++; +#endif + op_tc_if_a_z_if_a_l3a_l3a(sc, arg); + sc->rec_p1 = sc->F; + sc->rec_p2 = sc->F; return(sc->value); } @@ -85178,7 +85481,6 @@ static bool op_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer code) if (!no_bool_opt(code)) { sc->pc = 0; - reset_opts(sc); if (bool_optimize(sc, if_test)) { opt_info *o, *o1, *o2, *o3; @@ -85204,17 +85506,11 @@ static bool op_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer code) while (true) { s7_int i1; - sc->pc = 0; if (o->v[0].fb(o)) break; - sc->pc++; i1 = o1->v[0].fi(o1); - sc->pc++; integer(val2) = o2->v[0].fi(o2); integer(val1) = i1; - sc->pc++; - /* sc->envir = outer_env; */ /* can this matter? all slots are preset */ integer(val3) = o3->v[0].fi(o3); - /* sc->envir = inner_env; */ } unstack(sc); return(op_tc_z(sc, if_true)); /* sc->inner_env in effect here since it was the last set above */ @@ -85223,17 +85519,15 @@ static bool op_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer code) } } } - else set_no_bool_opt(code); + set_no_bool_opt(code); } while (true) { - s7_pointer a1; if (fx_call(sc, if_test) != sc->F) break; - a1 = fx_call(sc, la); - sc->w = a1; + sc->rec_p1 = fx_call(sc, la); slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, a1); + slot_set_value(la_slot, sc->rec_p1); sc->envir = outer_env; slot_set_value(let_slot, fx_call(sc, let_var)); sc->envir = inner_env; @@ -85248,6 +85542,7 @@ static s7_pointer fx_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer arg) tc_rec_calls[OP_TC_LET_IF_A_Z_LAA]++; #endif op_tc_let_if_a_z_laa(sc, arg); + sc->rec_p1 = sc->F; return(sc->value); } @@ -85289,15 +85584,13 @@ static void op_tc_let_when_laa(s7_scheme *sc, bool when, s7_pointer code) laa_slot = next_slot(la_slot); while (true) { - s7_pointer a1; p = fx_call(sc, if_test); if (when) {if (p == sc->F) break;} else {if (p != sc->F) break;} for (p = if_true; is_pair(cdr(p)); p = cdr(p)) fx_call(sc, p); - a1 = fx_call(sc, la); - sc->w = a1; + sc->rec_p1 = fx_call(sc, la); slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, a1); + slot_set_value(la_slot, sc->rec_p1); sc->envir = outer_env; slot_set_value(let_slot, fx_call(sc, let_var)); sc->envir = inner_env; @@ -85313,6 +85606,7 @@ static s7_pointer fx_tc_let_when_laa(s7_scheme *sc, s7_pointer arg) tc_rec_calls[OP_TC_LET_WHEN_LAA]++; #endif op_tc_let_when_laa(sc, true, arg); + sc->rec_p1 = sc->F; return(sc->value); } @@ -85322,12 +85616,13 @@ static s7_pointer fx_tc_let_unless_laa(s7_scheme *sc, s7_pointer arg) tc_rec_calls[OP_TC_LET_WHEN_LAA]++; #endif op_tc_let_when_laa(sc, false, arg); + sc->rec_p1 = sc->F; return(sc->value); } static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code) { - s7_pointer outer_env, inner_env, let_var, let_slot, let_body, slots, result; + s7_pointer outer_env, inner_env, let_var, let_slot, cond_body, slots, result; /* code here == body in check_tc */ let_var = caadr(code); outer_env = sc->envir; @@ -85336,7 +85631,7 @@ static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code) push_stack_no_let_no_code(sc, OP_GC_PROTECT, inner_env); let_slot = let_slots(sc->envir); let_var = cdr(let_var); - let_body = cdaddr(code); + cond_body = cdaddr(code); slots = let_slots(outer_env); /* in the named let no-var case slots may contain the let name (it's the funclet) */ @@ -85345,7 +85640,7 @@ static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code) while (true) { s7_pointer p; - for (p = let_body; is_pair(p); p = cdr(p)) + for (p = cond_body; is_pair(p); p = cdr(p)) { if (fx_call(sc, car(p)) != sc->F) { @@ -85364,25 +85659,26 @@ static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code) while (true) { s7_pointer p; - for (p = let_body; is_pair(p); p = cdr(p)) + for (p = cond_body; is_pair(p); p = cdr(p)) { if (fx_call(sc, car(p)) != sc->F) { result = cdar(p); if (has_tc(result)) { - slot_set_value(slots, fx_call(sc, cdar(result))); + slot_set_value(slots, fx_call(sc, cdar(result))); /* arg to recursion */ sc->envir = outer_env; - slot_set_value(let_slot, fx_call(sc, let_var)); + slot_set_value(let_slot, fx_call(sc, let_var)); /* inner let var */ sc->envir = inner_env; break; } else goto TC_LET_COND_DONE; }}}} + let_set_has_pending_value(outer_env); while (true) { s7_pointer p; - for (p = let_body; is_pair(p); p = cdr(p)) + for (p = cond_body; is_pair(p); p = cdr(p)) { if (fx_call(sc, car(p)) != sc->F) { @@ -85394,7 +85690,7 @@ static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code) { s7_pointer slot, arg; for (slot = slots, arg = result; is_pair(arg); slot = next_slot(slot), arg = cdr(arg)) - slot_set_pending_value(slot, fx_call(sc, arg)); + slot_simply_set_pending_value(slot, fx_call(sc, arg)); for (slot = slots; tis_slot(slot); slot = next_slot(slot)) slot_set_value(slot, slot_pending_value(slot)); } @@ -85405,6 +85701,7 @@ static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code) } else goto TC_LET_COND_DONE; }}} + let_clear_has_pending_value(outer_env); TC_LET_COND_DONE: unstack(sc); @@ -85440,21 +85737,18 @@ static bool op_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer code) laa_slot = next_slot(la_slot); while (true) { - s7_pointer a1; if (fx_call(sc, c1) != sc->F) {c1 = cdr(c1); break;} if (fx_call(sc, c2) != sc->F) { - a1 = fx_call(sc, la1); - sc->w = a1; + sc->rec_p1 = fx_call(sc, la1); slot_set_value(laa_slot, fx_call(sc, laa1)); } else { - a1 = fx_call(sc, la2); - sc->w = a1; + sc->rec_p1 = fx_call(sc, la2); slot_set_value(laa_slot, fx_call(sc, laa2)); } - slot_set_value(la_slot, a1); + slot_set_value(la_slot, sc->rec_p1); } return(op_tc_z(sc, c1)); } @@ -85465,6 +85759,7 @@ static s7_pointer fx_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer arg) tc_rec_calls[OP_TC_COND_A_Z_A_LAA_LAA]++; #endif op_tc_cond_a_z_a_laa_laa(sc, arg); + sc->rec_p1 = sc->F; return(sc->value); } @@ -85759,6 +86054,45 @@ static s7_pointer op_recur_cond_a_a_opa_laaq(s7_scheme *sc) } +/* -------- if_a_a_opa_l3aq -------- */ +static void opinit_if_a_a_opa_l3aq(s7_scheme *sc) +{ + s7_pointer caller, l3a; + rec_set_test(sc, cdr(sc->code)); + rec_set_res(sc, cddr(sc->code)); + caller = opt3_pair(sc->code); + rec_set_f1(sc, cdr(caller)); + l3a = cdr(opt3_pair(caller)); + rec_set_f2(sc, l3a); + rec_set_f3(sc, cdr(l3a)); + rec_set_f4(sc, cddr(l3a)); + sc->rec_slot1 = let_slots(sc->envir); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_slot3 = next_slot(sc->rec_slot2); + sc->rec_call = c_callee(caller); +} + +static s7_pointer oprec_if_a_a_opa_l3aq(s7_scheme *sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return(sc->rec_resf(sc, sc->rec_resp)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot3, sc->rec_f4f(sc, sc->rec_f4p)); + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + set_car(sc->t2_2, oprec_if_a_a_opa_l3aq(sc)); + set_car(sc->t2_1, recur_pop(sc)); + return(sc->rec_call(sc, sc->t2_1)); +} + +static s7_pointer op_recur_if_a_a_opa_l3aq(s7_scheme *sc) +{ + opinit_if_a_a_opa_l3aq(sc); + return(oprec_if_a_a_opa_l3aq(sc)); +} + /* -------- if_a_a_opla_laq and if_a_opla_laq_a -------- */ typedef enum {OPT_PTR, OPT_INT, OPT_DBL, OPT_INT_0} opt_pid_t; @@ -85779,7 +86113,6 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op) if (is_c_function(s_func)) { sc->pc = 0; - reset_opts(sc); sc->rec_test_o = sc->opts[0]; if (bool_optimize(sc, cdr(sc->code))) { @@ -85795,7 +86128,6 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op) sc->rec_a1_o = sc->opts[sc->pc]; if (int_optimize(sc, cdadr(caller))) { - sc->rec_pc1 = sc->pc; sc->rec_a2_o = sc->opts[sc->pc]; if (int_optimize(sc, cdr(opt3_pair(caller)))) { @@ -85824,7 +86156,6 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op) sc->rec_result_o = sc->opts[start_pc]; if (float_optimize(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code))) { - sc->rec_pc1 = sc->pc; sc->rec_a1_o = sc->opts[sc->pc]; if (float_optimize(sc, cdadr(caller))) { @@ -85848,15 +86179,9 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op) static s7_int oprec_i_if_a_a_opla_laq(s7_scheme *sc) { s7_int i1, i2; - sc->pc = 0; if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) /* if_(A) */ - { - sc->pc++; - return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); /* if_a_(A) */ - } - sc->pc = sc->rec_pc1; + return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); /* if_a_(A) */ i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); /* save a1 */ - sc->pc++; integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); /* slot1 = a2 */ i2 = oprec_i_if_a_a_opla_laq(sc); /* save la2 */ integer(sc->rec_val1) = i1; /* slot1 = a1 */ @@ -85888,13 +86213,8 @@ static s7_int oprec_i_if_a_a_opla_laq_0(s7_scheme *sc) static s7_double oprec_d_if_a_a_opla_laq(s7_scheme *sc) { s7_double x1, x2; - sc->pc = 0; if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) - { - sc->pc++; - return(sc->rec_result_o->v[0].fd(sc->rec_result_o)); - } - sc->pc = sc->rec_pc1; + return(sc->rec_result_o->v[0].fd(sc->rec_result_o)); x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); x2 = oprec_d_if_a_a_opla_laq(sc); @@ -85917,15 +86237,9 @@ static s7_pointer oprec_if_a_a_opla_laq(s7_scheme *sc) static s7_int oprec_i_if_a_opla_laq_a(s7_scheme *sc) { s7_int i1, i2; - sc->pc = 0; if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o))) - { - sc->pc++; - return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); - } - sc->pc = sc->rec_pc1; + return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); - sc->pc++; integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); i2 = oprec_i_if_a_opla_laq_a(sc); integer(sc->rec_val1) = i1; @@ -85957,15 +86271,9 @@ static s7_int oprec_i_if_a_opla_laq_a_0(s7_scheme *sc) static s7_double oprec_d_if_a_opla_laq_a(s7_scheme *sc) { s7_double x1, x2; - sc->pc = 0; if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o))) - { - sc->pc++; - return(sc->rec_result_o->v[0].fd(sc->rec_result_o)); - } - sc->pc = sc->rec_pc1; + return(sc->rec_result_o->v[0].fd(sc->rec_result_o)); x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); - sc->pc++; real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); x2 = oprec_d_if_a_opla_laq_a(sc); real(sc->rec_val1) = x1; @@ -86104,6 +86412,17 @@ static s7_pointer op_recur_if_a_a_opla_la_laq(s7_scheme *sc) * version has immediate lookups, and since the data is (ahem) simple, the GC is not a factor. * The opt version has its own overheads, and has to do the same amount of stack manipulations. */ +static s7_pointer rec_x(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot1));} +static s7_pointer rec_y(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot2));} +static s7_pointer rec_z(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot3));} +static s7_pointer rec_sub_z1(s7_scheme *sc, s7_pointer code) +{ + s7_pointer x; + x = slot_value(sc->rec_slot3); + if (is_t_integer(x)) return(make_integer(sc, integer(x) - 1)); + return(minus_c1(sc, x)); +} + static void opinit_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) { s7_pointer caller, la1, la2, la3; @@ -86117,10 +86436,12 @@ static void opinit_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) rec_set_f1(sc, cdr(la1)); rec_set_f2(sc, cddr(la1)); + if (sc->rec_f2f == fx_u) sc->rec_f2f = rec_y; rec_set_f3(sc, cdddr(la1)); rec_set_f4(sc, cdr(la2)); rec_set_f5(sc, cddr(la2)); rec_set_f6(sc, cdddr(la2)); + if (sc->rec_f6f == fx_t) sc->rec_f6f = rec_x; sc->rec_f7p = cdr(la3); sc->rec_f7f = c_callee(sc->rec_f7p); @@ -86128,15 +86449,20 @@ static void opinit_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) sc->rec_f8p = cddr(la3); sc->rec_f8f = c_callee(sc->rec_f8p); + if (sc->rec_f8f == fx_t) sc->rec_f8f = rec_x; sc->rec_f8p = car(sc->rec_f8p); sc->rec_f9p = cdddr(la3); sc->rec_f9f = c_callee(sc->rec_f9p); + if (sc->rec_f9f == fx_u) sc->rec_f9f = rec_y; sc->rec_f9p = car(sc->rec_f9p); sc->rec_slot1 = let_slots(sc->envir); sc->rec_slot2 = next_slot(sc->rec_slot1); sc->rec_slot3 = next_slot(sc->rec_slot2); + if (cadddr(la1) == slot_symbol(sc->rec_slot3)) sc->rec_f3f = rec_z; + if (caddr(la2) == slot_symbol(sc->rec_slot3)) sc->rec_f5f = rec_z; + if ((sc->rec_f7f == fx_subtract_s1) && (cadadr(la3) == slot_symbol(sc->rec_slot3))) sc->rec_f7f = rec_sub_z1; } static s7_pointer oprec_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) @@ -86456,7 +86782,6 @@ static opt_pid_t opinit_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) (is_t_integer(slot_value(sc->rec_slot2)))) { sc->pc = 0; - reset_opts(sc); sc->rec_test_o = sc->opts[0]; if (bool_optimize(sc, cadr(sc->code))) { @@ -86465,7 +86790,6 @@ static opt_pid_t opinit_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) { s7_pointer laa1; sc->rec_a1_o = sc->opts[sc->pc]; - sc->rec_pc1 = sc->pc; laa1 = caddr(sc->code); if (bool_optimize(sc, laa1)) { @@ -86476,7 +86800,6 @@ static opt_pid_t opinit_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) if (int_optimize(sc, cddadr(laa1))) { s7_pointer laa2, laa3; - sc->rec_pc2 = sc->pc; sc->rec_a4_o = sc->opts[sc->pc]; laa2 = cadr(cadddr(sc->code)); laa3 = caddr(laa2); @@ -86529,26 +86852,17 @@ static opt_pid_t opinit_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) { s7_int i1, i2; - sc->pc = 0; if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) - { - sc->pc++; - return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); - } - sc->pc = sc->rec_pc1; + return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); if (sc->rec_a1_o->v[0].fb(sc->rec_a1_o)) { i1 = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); - sc->pc++; integer(sc->rec_val2) = sc->rec_a3_o->v[0].fi(sc->rec_a3_o); integer(sc->rec_val1) = i1; return(oprec_i_cond_a_a_a_laa_lopa_laaq(sc)); } - sc->pc = sc->rec_pc2; i1 = sc->rec_a4_o->v[0].fi(sc->rec_a4_o); - sc->pc++; i2 = sc->rec_a5_o->v[0].fi(sc->rec_a5_o); - sc->pc++; integer(sc->rec_val2) = sc->rec_a6_o->v[0].fi(sc->rec_a6_o); integer(sc->rec_val1) = i2; integer(sc->rec_val2) = oprec_i_cond_a_a_a_laa_lopa_laaq(sc); @@ -86612,7 +86926,6 @@ static void wrap_recur_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) } } - static void wrap_recur(s7_scheme *sc, s7_pointer (*recur)(s7_scheme *sc)) { tick_tc_rec(sc); @@ -86638,7 +86951,7 @@ static bool op_check_safe_c_s(s7_scheme *sc) static void op_safe_c_p(s7_scheme *sc) { check_stack_size(sc); - push_stack_no_args(sc, OP_SAFE_C_P_1, sc->code); + push_stack_no_args_direct(sc, OP_SAFE_C_P_1, sc->code); sc->code = T_Pair(cadr(sc->code)); } @@ -86650,14 +86963,14 @@ static void op_safe_c_p_1(s7_scheme *sc) static void op_not_p(s7_scheme *sc) { - push_stack_no_args(sc, OP_NOT_P_1, sc->code); + push_stack_no_args_direct(sc, OP_NOT_P_1, sc->code); sc->code = T_Pair(cadr(sc->code)); } static void op_safe_c_ssp(s7_scheme *sc) { check_stack_size(sc); - push_stack_no_args(sc, OP_SAFE_C_SSP_1, sc->code); + push_stack_no_args_direct(sc, OP_SAFE_C_SSP_1, sc->code); sc->code = opt3_pair(sc->code); } @@ -86841,7 +87154,7 @@ static void op_safe_c_function_star_aa(s7_scheme *sc) static void op_safe_c_ps(s7_scheme *sc) { - push_stack_no_args(sc, OP_SAFE_C_PS_1, sc->code); /* gotta wait in this case */ + push_stack_no_args_direct(sc, OP_SAFE_C_PS_1, sc->code); /* gotta wait in this case */ sc->code = cadr(sc->code); } @@ -86973,7 +87286,7 @@ static void op_safe_c_ap(s7_scheme *sc) static void op_safe_c_pp(s7_scheme *sc) { check_stack_size(sc); - push_stack_no_args(sc, OP_SAFE_C_PP_1, sc->code); + push_stack_no_args_direct(sc, OP_SAFE_C_PP_1, sc->code); sc->code = cadr(sc->code); } @@ -87003,8 +87316,16 @@ static void op_safe_c_pp_3_mv(s7_scheme *sc) static void op_safe_c_pp_5(s7_scheme *sc) { - /* 1 mv, 2, normal */ - sc->args = s7_append(sc, sc->args, list_1(sc, sc->value)); + /* 1 mv, 2 normal, sc->args was copied above (and this is a safe c function so its args are in no danger) */ + s7_pointer p; + if (is_null(sc->args)) + sc->args = list_1(sc, sc->value); + else + { + for (p = sc->args; is_pair(cdr(p)); p = cdr(p)); + set_cdr(p, cons(sc, sc->value, sc->nil)); + } + /* sc->args = s7_append(sc, sc->args, list_1(sc, sc->value)); */ sc->code = c_function_base(opt1_cfunc(sc->code)); } @@ -87029,11 +87350,9 @@ static inline bool collect_fp_args(s7_scheme *sc, opcode_t op, s7_pointer args) static inline bool collect_fp_args(s7_scheme *sc, opcode_t op, s7_pointer args) { s7_pointer p; - sc->args = args; for (p = sc->code; (is_pair(p)) && (has_fx(p)); p = cdr(p)) sc->args = cons(sc, fx_call(sc, p), sc->args); /* reversed before apply in OP_SAFE_C_FP_1 */ - if (is_pair(p)) { push_stack(sc, op, sc->args, cdr(p)); @@ -87053,7 +87372,7 @@ static void op_safe_c_fp(s7_scheme *sc) /* code: (func . args) where at least on sc->args = cons(sc, fx_call(sc, p), sc->args); /* reversed before apply in OP_SAFE_C_FP_1 */ /* there's always at least one non-fx arg (the "p" in "fp"), also lots of recurs here */ #if S7_DEBUGGING - if (!is_pair(p)) fprintf(stderr, "%s: all fxable: %s\n", __func__, DISPLAY(sc->code)); + if (!is_pair(p)) fprintf(stderr, "%s: all fxable: %s\n", __func__, display(sc->code)); #endif push_stack(sc, ((intptr_t)((is_pair(cdr(p))) ? OP_SAFE_C_FP_1 : OP_SAFE_C_FP_2)), sc->args, cdr(p)); sc->code = T_Pair(car(p)); @@ -87100,7 +87419,6 @@ static void op_safe_closure_fp(s7_scheme *sc) static void op_safe_closure_fp_1(s7_scheme *sc) { - /* in-coming sc->value has the current arg value, sc->args is all previous args */ uint64_t id; s7_pointer x, z; @@ -87194,7 +87512,7 @@ static void op_c_a(s7_scheme *sc) static void op_c_p(s7_scheme *sc) { - push_stack_no_args(sc, OP_C_P_1, sc->code); + push_stack_no_args_direct(sc, OP_C_P_1, sc->code); sc->code = T_Pair(cadr(sc->code)); } @@ -87474,7 +87792,7 @@ static bool op_load_close_and_pop_if_eof(s7_scheme *sc) } #if S7_DEBUGGING if (!is_loader_port(sc->input_port)) - fprintf(stderr, "%s not loading?\n", DISPLAY(sc->input_port)); + fprintf(stderr, "%s not loading?\n", display(sc->input_port)); /* if *#readers* func hits error, clear_loader_port might not be undone? */ #endif s7_close_input_port(sc, sc->input_port); @@ -87782,7 +88100,7 @@ static inline void op_map_gather(s7_scheme *sc) static s7_pointer eval(s7_scheme *sc, opcode_t first_op) { #if SHOW_EVAL_OPS - safe_print(fprintf(stderr, "eval[%d]:, %s %s %s\n", __LINE__, op_names[first_op], DISPLAY_80(sc->code), DISPLAY_80(sc->args))); + safe_print(fprintf(stderr, "eval[%d]:, %s %s %s\n", __LINE__, op_names[first_op], display_80(sc->code), display_80(sc->args))); #endif sc->cur_op = first_op; goto TOP_NO_POP; @@ -87803,7 +88121,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) TOP_NO_POP: #if SHOW_EVAL_OPS - safe_print(fprintf(stderr, "%s (%d), code: %s\n", op_names[sc->cur_op], (int)(sc->cur_op), DISPLAY_80(sc->code))); + safe_print(fprintf(stderr, "%s (%d), code: %s\n", op_names[sc->cur_op], (int)(sc->cur_op), display_80(sc->code))); #endif #if WITH_PROFILE profile_at_start = sc->code; @@ -87819,7 +88137,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SAFE_C_D: if (!c_function_is_ok(sc, sc->code)) break; /* break refers to the switch statement */ case HOP_SAFE_C_D: sc->value = d_call(sc, sc->code); continue; /* continue refers to the outer while loop -- unfortunate C ambiguity */ - case OP_SAFE_C_S: if (op_check_safe_c_s(sc)) goto EVAL; + case OP_SAFE_C_S: if (op_check_safe_c_s(sc)) goto EVAL; case HOP_SAFE_C_S: op_safe_c_s(sc); continue; case OP_SAFE_C_SS: if (!c_function_is_ok(sc, sc->code)) break; @@ -87946,14 +88264,17 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SAFE_C_opSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; case HOP_SAFE_C_opSq: sc->value = fx_c_opsq(sc, sc->code); continue; - case OP_SAFE_C_op_opSq_q: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSq_q: sc->value = fx_c_op_opsq_q(sc, sc->code); continue; + case OP_SAFE_C_op_opSqq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; + case HOP_SAFE_C_op_opSqq: sc->value = fx_c_op_opsqq(sc, sc->code); continue; + + case OP_SAFE_C_op_opSq_Cq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; + case HOP_SAFE_C_op_opSq_Cq: sc->value = fx_c_op_opsq_cq(sc, sc->code); continue; - case OP_SAFE_C_op_S_opSq_q: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, caddr(cadr(sc->code))))) break; - case HOP_SAFE_C_op_S_opSq_q: sc->value = fx_c_op_s_opsq_q(sc, sc->code); continue; + case OP_SAFE_C_op_S_opSqq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, caddadr(sc->code)))) break; + case HOP_SAFE_C_op_S_opSqq: sc->value = fx_c_op_s_opsqq(sc, sc->code); continue; - case OP_SAFE_C_op_opSq_S_q: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSq_S_q: sc->value = fx_c_op_opsq_s_q(sc, sc->code); continue; + case OP_SAFE_C_op_opSq_Sq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; + case HOP_SAFE_C_op_opSq_Sq: sc->value = fx_c_op_opsq_sq(sc, sc->code); continue; case OP_SAFE_C_PS: if (!c_function_is_ok(sc, sc->code)) break; case HOP_SAFE_C_PS: op_safe_c_ps(sc); goto EVAL; @@ -88032,25 +88353,25 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SAFE_C_opSSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; case HOP_SAFE_C_opSSq_S: sc->value = fx_c_opssq_s(sc, sc->code); continue; - case OP_SAFE_C_op_opSSq_q_C: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSSq_q_C: sc->value = fx_c_op_opssq_q_c(sc, sc->code); continue; + case OP_SAFE_C_op_opSSqq_C: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; + case HOP_SAFE_C_op_opSSqq_C: sc->value = fx_c_op_opssqq_c(sc, sc->code); continue; - case OP_SAFE_C_op_opSSq_q_S: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSSq_q_S: sc->value = fx_c_op_opssq_q_s(sc, sc->code); continue; + case OP_SAFE_C_op_opSSqq_S: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; + case HOP_SAFE_C_op_opSSqq_S: sc->value = fx_c_op_opssqq_s(sc, sc->code); continue; case OP_SAFE_C_op_opSSq_Sq_S: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; case HOP_SAFE_C_op_opSSq_Sq_S: sc->value = fx_c_op_opssq_sq_s(sc, sc->code); continue; - case OP_SAFE_C_op_opSq_q_C: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSq_q_C: sc->value = fx_c_op_opsq_q_c(sc, sc->code); continue; + case OP_SAFE_C_op_opSqq_C: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; + case HOP_SAFE_C_op_opSqq_C: sc->value = fx_c_op_opsqq_c(sc, sc->code); continue; - case OP_SAFE_C_S_op_opSq_Cq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, caddr(sc->code))) || (!c_function_is_ok(sc, cadr(caddr(sc->code))))) break; + case OP_SAFE_C_S_op_opSq_Cq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, caddr(sc->code))) || (!c_function_is_ok(sc, cadaddr(sc->code)))) break; case HOP_SAFE_C_S_op_opSq_Cq: sc->value = fx_c_s_op_opsq_cq(sc, sc->code); continue; - case OP_SAFE_C_S_op_S_opSqq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, caddr(sc->code))) || (!c_function_is_ok(sc, caddr(caddr(sc->code))))) break; + case OP_SAFE_C_S_op_S_opSqq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, caddr(sc->code))) || (!c_function_is_ok(sc, caddaddr(sc->code)))) break; case HOP_SAFE_C_S_op_S_opSqq: sc->value = fx_c_s_op_s_opsqq(sc, sc->code); continue; - case OP_SAFE_C_S_op_S_opSSqq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, caddr(sc->code))) || (!c_function_is_ok(sc, caddr(caddr(sc->code))))) break; + case OP_SAFE_C_S_op_S_opSSqq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, caddr(sc->code))) || (!c_function_is_ok(sc, caddaddr(sc->code)))) break; case HOP_SAFE_C_S_op_S_opSSqq: sc->value = fx_c_s_op_s_opssqq(sc, sc->code); continue; case OP_SAFE_C_S_op_opSSq_opSSqq: if (!c_function_is_ok(sc, sc->code)) break; @@ -88221,15 +88542,15 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SAFE_CLOSURE_S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_S_A: sc->value = fx_safe_closure_s_a(sc, sc->code); continue; - case OP_SAFE_CLOSURE_ID_S: if (!closure_is_eq(sc)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} - case HOP_SAFE_CLOSURE_ID_S: sc->value = fx_safe_closure_id_s(sc, sc->code); continue; - case OP_SAFE_CLOSURE_S_TO_S: if (!closure_is_eq(sc)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_S_TO_S: sc->value = fx_safe_closure_s_to_s(sc, sc->code); continue; case OP_SAFE_CLOSURE_S_TO_SC: if (!closure_is_eq(sc)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_S_TO_SC: sc->value = fx_safe_closure_s_to_sc(sc, sc->code); continue; + case OP_SAFE_CLOSURE_A_TO_SC: if (!closure_is_eq(sc)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_A_TO_SC: sc->value = fx_safe_closure_a_to_sc(sc, sc->code); continue; + case OP_CLOSURE_C: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_C: op_closure_c(sc); goto EVAL; @@ -88248,7 +88569,6 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) break; case HOP_CLOSURE_P: op_closure_p(sc); goto EVAL; case OP_CLOSURE_P_1: op_closure_p_1(sc); goto BEGIN; - case OP_CLOSURE_P_MV: op_closure_p_mv(sc); goto APPLY; case OP_SAFE_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) break; case HOP_SAFE_CLOSURE_P: op_safe_closure_p(sc); goto EVAL; @@ -88272,12 +88592,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) break; case HOP_CLOSURE_AP: op_closure_ap(sc); goto EVAL; case OP_CLOSURE_AP_1: op_closure_ap_1(sc); goto BEGIN; - case OP_CLOSURE_AP_MV: op_closure_ap_mv(sc); goto APPLY; case OP_CLOSURE_PA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) break; case HOP_CLOSURE_PA: op_closure_pa(sc); goto EVAL; case OP_CLOSURE_PA_1: op_closure_pa_1(sc); goto BEGIN; - case OP_CLOSURE_PA_MV: op_closure_pa_mv(sc); goto APPLY; + + case OP_CLOSURE_PP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) break; + case HOP_CLOSURE_PP: op_closure_pp(sc); goto EVAL; + case OP_CLOSURE_PP_1: op_closure_pp_1(sc); goto EVAL; case OP_SAFE_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) break; case HOP_SAFE_CLOSURE_AP: op_safe_closure_ap(sc); goto EVAL; @@ -88287,6 +88609,17 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case HOP_SAFE_CLOSURE_PA: op_safe_closure_pa(sc); goto EVAL; case OP_SAFE_CLOSURE_PA_1: op_safe_closure_pa_1(sc); goto BEGIN; + case OP_SAFE_CLOSURE_PP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) break; + case HOP_SAFE_CLOSURE_PP: op_safe_closure_pp(sc); goto EVAL; + case OP_SAFE_CLOSURE_PP_1: op_safe_closure_pp_1(sc); goto EVAL; + + /* TODO: type check should ignore T_SAFE_CLOSURE */ + case OP_SAFE_OR_UNSAFE_CLOSURE_3P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) break; + case HOP_SAFE_OR_UNSAFE_CLOSURE_3P: op_safe_or_unsafe_closure_3p(sc); goto EVAL; + case OP_SAFE_OR_UNSAFE_CLOSURE_3P_1: if (!op_safe_or_unsafe_closure_3p_1(sc)) goto EVAL; goto BEGIN; + case OP_SAFE_OR_UNSAFE_CLOSURE_3P_2: if (!op_safe_or_unsafe_closure_3p_2(sc)) goto EVAL; goto BEGIN; + case OP_SAFE_OR_UNSAFE_CLOSURE_3P_3: op_safe_or_unsafe_closure_3p_3(sc); goto BEGIN; + case OP_CLOSURE_FA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) break; case HOP_CLOSURE_FA: op_closure_fa(sc); goto EVAL; @@ -88371,6 +88704,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SAFE_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) break; case HOP_SAFE_CLOSURE_3S: op_safe_closure_3s(sc); goto BEGIN; + case OP_SAFE_CLOSURE_3S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 3)) {if (op_unknown_all_s(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_3S_A: sc->value = fx_safe_closure_3s_a(sc, sc->code); continue; + case OP_CLOSURE_ALL_S: switch (op_check_closure_all_s(sc)) {case goto_eval: goto EVAL; case goto_unopt: goto UNOPT; default: break;} case HOP_CLOSURE_ALL_S: op_closure_all_s(sc); goto EVAL; @@ -88391,43 +88727,43 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) goto EVAL; - case OP_TC_AND_A_OR_A_LA: tick_tc_rec(sc); op_tc_and_a_or_a_la(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_LA: tick_tc_rec(sc); op_tc_or_a_and_a_la(sc, sc->code); continue; - case OP_TC_AND_A_OR_A_LAA: tick_tc_rec(sc); op_tc_and_a_or_a_laa(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_LAA: tick_tc_rec(sc); op_tc_or_a_and_a_laa(sc, sc->code); continue; - case OP_TC_OR_A_A_AND_A_A_LA: tick_tc_rec(sc); op_tc_or_a_a_and_a_a_la(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_A_L3A: tick_tc_rec(sc); op_tc_or_a_and_a_a_l3a(sc, true, sc->code); continue; - - case OP_TC_LET_WHEN_LAA: tick_tc_rec(sc); op_tc_let_when_laa(sc, true, sc->code); continue; - case OP_TC_LET_UNLESS_LAA: tick_tc_rec(sc); op_tc_let_when_laa(sc, false, sc->code); continue; - + case OP_TC_AND_A_OR_A_LA: tick_tc_rec(sc); op_tc_and_a_or_a_la(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_LA: tick_tc_rec(sc); op_tc_or_a_and_a_la(sc, sc->code); continue; + case OP_TC_AND_A_OR_A_LAA: tick_tc_rec(sc); op_tc_and_a_or_a_laa(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_LAA: tick_tc_rec(sc); op_tc_or_a_and_a_laa(sc, sc->code); continue; + case OP_TC_AND_A_OR_A_A_LA: tick_tc_rec(sc); op_tc_and_a_or_a_a_la(sc, sc->code); continue; + case OP_TC_OR_A_A_AND_A_A_LA: tick_tc_rec(sc); op_tc_or_a_a_and_a_a_la(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_A_L3A: tick_tc_rec(sc); op_tc_or_a_and_a_a_l3a(sc, true, sc->code); continue; + case OP_TC_LET_WHEN_LAA: tick_tc_rec(sc); op_tc_let_when_laa(sc, true, sc->code); continue; + case OP_TC_LET_UNLESS_LAA: tick_tc_rec(sc); op_tc_let_when_laa(sc, false, sc->code); continue; case OP_TC_COND_A_Z_A_Z_LAA: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_z_laa(sc, true, sc->code)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_LAA_LAA: tick_tc_rec(sc); if (op_tc_cond_a_z_a_laa_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_LET_COND: tick_tc_rec(sc); if (op_tc_let_cond(sc, sc->code)) continue; goto EVAL; - - case OP_TC_IF_A_Z_LA: tick_tc_rec(sc); if (op_tc_if_a_z_la(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_LAA: tick_tc_rec(sc); if (op_tc_if_a_z_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_LA_Z: tick_tc_rec(sc); if (op_tc_if_a_la_z(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_LAA_Z: tick_tc_rec(sc); if (op_tc_if_a_laa_z(sc, sc->code)) continue; goto EVAL; - - case OP_TC_IF_A_Z_IF_A_Z_LA: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_z_la(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_LA_Z: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_la_z(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_Z_LAA: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_z_laa(sc, false, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_LAA_Z: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_laa_z(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_T_AND_A_A_L3A: tick_tc_rec(sc); op_tc_or_a_and_a_a_l3a(sc, false, sc->code); continue; - - case OP_TC_LET_IF_A_Z_LAA: tick_tc_rec(sc); if (op_tc_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_CASE_LA: tick_tc_rec(sc); if (op_tc_case_la(sc, sc->code)) continue; goto BEGIN; - - case OP_RECUR_IF_A_A_opA_LAq: wrap_recur(sc, op_recur_if_a_a_opa_laq); continue; - case OP_RECUR_IF_A_opA_LAq_A: wrap_recur(sc, op_recur_if_a_opa_laq_a); continue; - case OP_RECUR_IF_A_A_opA_LAAq: wrap_recur(sc, op_recur_if_a_a_opa_laaq); continue; - case OP_RECUR_IF_A_opA_LAAq_A: wrap_recur(sc, op_recur_if_a_opa_laaq_a); continue; - case OP_RECUR_IF_A_A_opLA_LAq: wrap_recur_if_a_a_opla_laq(sc, true); continue; - case OP_RECUR_IF_A_opLA_LAq_A: wrap_recur_if_a_a_opla_laq(sc, false); continue; - case OP_RECUR_IF_A_A_opA_LA_LAq: wrap_recur(sc, op_recur_if_a_a_opa_la_laq); continue; - case OP_RECUR_IF_A_opA_LA_LAq_A: wrap_recur(sc, op_recur_if_a_opa_la_laq_a); continue; - + case OP_TC_COND_A_Z_A_LAA_LAA: tick_tc_rec(sc); if (op_tc_cond_a_z_a_laa_laa(sc, sc->code)) continue; goto EVAL; + case OP_TC_LET_COND: tick_tc_rec(sc); if (op_tc_let_cond(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_LA: tick_tc_rec(sc); if (op_tc_if_a_z_la(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_LAA: tick_tc_rec(sc); if (op_tc_if_a_z_laa(sc, sc->code, true)) continue; goto EVAL; + case OP_TC_IF_A_Z_L3A: tick_tc_rec(sc); if (op_tc_if_a_z_l3a(sc, sc->code, true)) continue; goto EVAL; + case OP_TC_IF_A_L3A_Z: tick_tc_rec(sc); if (op_tc_if_a_z_l3a(sc, sc->code, false)) continue; goto EVAL; + case OP_TC_IF_A_LA_Z: tick_tc_rec(sc); if (op_tc_if_a_la_z(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_LAA_Z: tick_tc_rec(sc); if (op_tc_if_a_z_laa(sc, sc->code, false)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_Z_LA: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, false)) continue; goto EVAL; + case OP_TC_COND_A_Z_A_Z_LA: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, true)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_LA_Z: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, false)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_Z_LAA: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_z_laa(sc, false, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_L3A_L3A: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_l3a_l3a(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_LAA_Z: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_laa_z(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_T_AND_A_A_L3A: tick_tc_rec(sc); op_tc_or_a_and_a_a_l3a(sc, false, sc->code); continue; + case OP_TC_LET_IF_A_Z_LAA: tick_tc_rec(sc); if (op_tc_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; + case OP_TC_CASE_LA: tick_tc_rec(sc); if (op_tc_case_la(sc, sc->code)) continue; goto BEGIN; + + case OP_RECUR_IF_A_A_opA_LAq: wrap_recur(sc, op_recur_if_a_a_opa_laq); continue; + case OP_RECUR_IF_A_opA_LAq_A: wrap_recur(sc, op_recur_if_a_opa_laq_a); continue; + case OP_RECUR_IF_A_A_opA_LAAq: wrap_recur(sc, op_recur_if_a_a_opa_laaq); continue; + case OP_RECUR_IF_A_A_opA_L3Aq: wrap_recur(sc, op_recur_if_a_a_opa_l3aq); continue; + case OP_RECUR_IF_A_opA_LAAq_A: wrap_recur(sc, op_recur_if_a_opa_laaq_a); continue; + case OP_RECUR_IF_A_A_opLA_LAq: wrap_recur_if_a_a_opla_laq(sc, true); continue; + case OP_RECUR_IF_A_opLA_LAq_A: wrap_recur_if_a_a_opla_laq(sc, false); continue; + case OP_RECUR_IF_A_A_opA_LA_LAq: wrap_recur(sc, op_recur_if_a_a_opa_la_laq); continue; + case OP_RECUR_IF_A_opA_LA_LAq_A: wrap_recur(sc, op_recur_if_a_opa_la_laq_a); continue; case OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq: wrap_recur(sc, op_recur_if_a_a_lopl3a_l3a_l3aq); continue; case OP_RECUR_IF_A_A_AND_A_LAA_LAA: wrap_recur(sc, op_recur_if_a_a_and_a_laa_laa); continue; case OP_RECUR_IF_A_A_opLA_LA_LAq: wrap_recur(sc, op_recur_if_a_a_opla_la_laq); continue; @@ -88445,6 +88781,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_STAR_A: safe_closure_star_a(sc, sc->code); goto BEGIN; + case OP_SAFE_CLOSURE_STAR_A1: + if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_STAR_A1: safe_closure_star_a1(sc, sc->code); goto BEGIN; + + case OP_SAFE_CLOSURE_STAR_KA: + if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_STAR_KA: safe_closure_star_ka(sc, sc->code); goto BEGIN; + case OP_SAFE_CLOSURE_STAR_AA: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) break; case HOP_SAFE_CLOSURE_STAR_AA: safe_closure_star_aa(sc, sc->code); goto BEGIN; @@ -88476,6 +88820,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) closure_star_a(sc, sc->code); goto BEGIN; + case OP_CLOSURE_STAR_KA: + if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_CLOSURE_STAR_KA: closure_star_ka(sc, sc->code); goto BEGIN; + case OP_CLOSURE_STAR_FX: switch (op_check_closure_star_fx(sc)) {case goto_eval: goto EVAL; case goto_unopt: goto UNOPT; default: break;} case HOP_CLOSURE_STAR_FX: @@ -88565,7 +88913,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_UNOPT: #if UNOPT_PRINT - fprintf(stderr, "unopt %s\n", DISPLAY_80(sc->code)); + fprintf(stderr, "unopt %s\n", display_80(sc->code)); #endif goto UNOPT; @@ -88602,7 +88950,6 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) sc->args = sc->nil; EVAL_ARGS: /* first time, value = op, args = nil, code is args */ - /* fprintf(stderr, "%d %s\n", __LINE__, DISPLAY(sc->code)); */ if (is_pair(sc->code)) /* evaluate current arg -- must check for pair here, not sc->nil (improper list as args) */ { if ((sc->safety > NO_SAFETY) && @@ -88634,9 +88981,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) else { /* here we know sc->code is a pair, cdr(sc->code) is not null, sc->value is the previous arg's value */ - s7_pointer x; - x = cons(sc, sc->value, sc->args); - sc->args = x; + sc->args = cons(sc, sc->value, sc->args); goto EVAL_ARGS_PAIR; } } @@ -88662,7 +89007,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_APPLY: set_current_code(sc, history_cons(sc, sc->code, sc->args)); #if SHOW_EVAL_OPS - safe_print(fprintf(stderr, " apply %s to %s\n", DISPLAY_80(sc->code), DISPLAY_80(sc->args))); + safe_print(fprintf(stderr, " apply %s to %s\n", display_80(sc->code), display_80(sc->args))); #endif switch (type(sc->code)) { @@ -88746,7 +89091,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SAFE_DOTIMES: SAFE_DOTIMES: /* check_do */ - switch (safe_dotimes_ex(sc)) + switch (op_safe_dotimes(sc)) { case goto_safe_do_end_clauses: if (is_null(sc->code)) continue; goto DO_END_CODE; case goto_do_end_clauses: goto DO_END_CLAUSES; @@ -88757,7 +89102,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SAFE_DO: SAFE_DO: /* from check_do */ - switch (safe_do_ex(sc)) + switch (op_safe_do(sc)) { case goto_safe_do_end_clauses: if (is_null(sc->code)) /* I don't think multiple values (as test result) can happen here -- all safe do loops involve counters by 1 to some integer end */ @@ -88770,7 +89115,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_DOTIMES_P: DOTIMES_P: /* from check_do */ - switch (dotimes_p_ex(sc)) + switch (op_dotimes_p(sc)) { case goto_do_end_clauses: goto DO_END_CLAUSES; case goto_do_unchecked: goto DO_UNCHECKED; @@ -88779,7 +89124,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_DOX: DOX: /* from check_do */ - switch (dox_ex(sc)) + switch (op_dox(sc)) { case goto_do_end_clauses: goto DO_END_CLAUSES; case goto_start: continue; @@ -88826,7 +89171,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) } #if 0 fprintf(stderr, "----------------------------------------\n"); - fprintf(stderr, "%s (do %s\n %s\n %s)\n\n", op_names[optimize_op(sc->code)], DISPLAY_80(cadr(sc->code)), DISPLAY_80(caddr(sc->code)), DISPLAY_80(cdddr(sc->code))); + fprintf(stderr, "%s (do %s\n %s\n %s)\n\n", op_names[optimize_op(sc->code)], display_80(cadr(sc->code)), display_80(caddr(sc->code)), display_80(cdddr(sc->code))); #endif case OP_DO_UNCHECKED: op_do_unchecked(sc); @@ -89002,7 +89347,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_IF1: if (op_if1(sc)) goto EVAL; continue; case OP_IF_A_CC: sc->value = fx_if_a_cc(sc, sc->code); continue; case OP_IF_A_A: sc->value = fx_if_a_a(sc, sc->code); continue; + case OP_IF_S_AA: sc->value = fx_if_s_aa(sc, sc->code); continue; case OP_IF_A_AA: sc->value = fx_if_a_aa(sc, sc->code); continue; + case OP_IF_AND2_SA: sc->value = fx_if_and2_sa(sc, sc->code); continue; case OP_IF_NOT_A_A: sc->value = fx_if_not_a_a(sc, sc->code); continue; case OP_IF_NOT_A_AA: sc->value = fx_if_not_a_aa(sc, sc->code); continue; @@ -89164,10 +89511,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_LET_opaSSq_E_OLD: op_let_opassq_e_old(sc); goto EVAL; case OP_LET_opaSSq_E_NEW: op_let_opassq_e_new(sc); goto EVAL; - case OP_LET_STAR_FX_OLD: op_let_star_fx_old(sc); goto BEGIN; - case OP_LET_STAR_FX_NEW: op_let_star_fx_new(sc); goto BEGIN; - case OP_LET_STAR_FX_A_OLD: op_let_star_fx_a_old(sc); continue; - case OP_LET_STAR_FX_A_NEW: op_let_star_fx_a_new(sc); continue; + case OP_LET_STAR_FX: op_let_star_fx(sc); goto BEGIN; + case OP_LET_STAR_FX_A: op_let_star_fx_a(sc); continue; case OP_NAMED_LET_STAR: op_named_let_star(sc); goto EVAL; case OP_LET_STAR2: op_let_star2(sc); goto EVAL; @@ -89206,6 +89551,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_LET_TEMP_FX: op_let_temp_fx(sc); goto BEGIN; case OP_LET_TEMP_FX_1: op_let_temp_fx_1(sc); goto BEGIN; case OP_LET_TEMP_SETTER: op_let_temp_setter(sc); goto BEGIN; + case OP_LET_TEMP_A_A: sc->value = fx_let_temp_a_a(sc, sc->code); continue; case OP_LET_TEMP_UNWIND: op_let_temp_unwind(sc); continue; case OP_LET_TEMP_S7_UNWIND: op_let_temp_s7_unwind(sc); continue; @@ -89340,13 +89686,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_CASE_A_G_G: sc->value = fx_call(sc, cdr(sc->code)); if (op_case_g_g(sc)) goto TOP_NO_POP; goto FEED_TO; case OP_CASE_S_G_G: sc->value = lookup_checked(sc, cadr(sc->code)); if (op_case_g_g(sc)) goto TOP_NO_POP; goto FEED_TO; - case OP_CASE_P_G_G: push_stack_no_args(sc, OP_CASE_G_G, sc->code); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_P_E_S: push_stack_no_args(sc, OP_CASE_E_S, sc->code); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_P_S_S: push_stack_no_args(sc, OP_CASE_S_S, sc->code); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_P_I_S: push_stack_no_args(sc, OP_CASE_I_S, sc->code); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_P_G_S: push_stack_no_args(sc, OP_CASE_G_S, sc->code); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_P_E_G: push_stack_no_args(sc, OP_CASE_E_G, sc->code); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_P_S_G: push_stack_no_args(sc, OP_CASE_S_G, sc->code); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_G_G: push_stack_no_args_direct(sc, OP_CASE_G_G, sc->code); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_E_S: push_stack_no_args_direct(sc, OP_CASE_E_S, sc->code); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_S_S: push_stack_no_args_direct(sc, OP_CASE_S_S, sc->code); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_I_S: push_stack_no_args_direct(sc, OP_CASE_I_S, sc->code); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_G_S: push_stack_no_args_direct(sc, OP_CASE_G_S, sc->code); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_E_G: push_stack_no_args_direct(sc, OP_CASE_E_G, sc->code); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_S_G: push_stack_no_args_direct(sc, OP_CASE_S_G, sc->code); sc->code = cadr(sc->code); goto EVAL; case OP_CASE_A_E_S: sc->value = fx_call(sc, cdr(sc->code)); op_case_e_s(sc); goto EVAL; case OP_CASE_S_E_S: sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */ @@ -89381,7 +89727,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_ERROR_HOOK_QUIT: op_error_hook_quit(sc); #if S7_DEBUGGING - fprintf(stderr, "%d: op_error_hook_quit did not jump, returns %s\n", __LINE__, DISPLAY(sc->value)); + fprintf(stderr, "%d: op_error_hook_quit did not jump, returns %s\n", __LINE__, display(sc->value)); #endif case OP_EVAL_DONE: return(sc->F); @@ -89590,13 +89936,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_READ_BYTE_VECTOR: if (op_read_byte_vector(sc)) continue; goto POP_READ_LIST; default: - fprintf(stderr, "unknown operator: %" print_pointer " in %s\n", sc->cur_op, DISPLAY(current_code(sc))); + fprintf(stderr, "unknown operator: %" print_pointer " in %s\n", sc->cur_op, display(current_code(sc))); return(sc->F); } clear_all_optimizations(sc, sc->code); #if UNOPT_PRINT - fprintf(stderr, "cleared: %s\n", DISPLAY_80(sc->code)); + fprintf(stderr, "cleared: %s\n", display_80(sc->code)); #endif UNOPT: @@ -90677,23 +91023,23 @@ static int32_t result_type_via_method(s7_scheme *sc, int32_t result_type, s7_poi s7_pointer f; if (!has_active_methods(sc, p)) return(-1); - f = find_method(sc, find_let(sc, p), sc->is_integer_symbol); + f = find_method_with_let(sc, p, sc->is_integer_symbol); if ((f != sc->undefined) && (is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))))) return(big_type_to_result_type(result_type, T_BIG_INTEGER)); - f = find_method(sc, find_let(sc, p), sc->is_rational_symbol); + f = find_method_with_let(sc, p, sc->is_rational_symbol); if ((f != sc->undefined) && (is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))))) return(big_type_to_result_type(result_type, T_BIG_RATIO)); - f = find_method(sc, find_let(sc, p), sc->is_real_symbol); + f = find_method_with_let(sc, p, sc->is_real_symbol); if ((f != sc->undefined) && (is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))))) return(big_type_to_result_type(result_type, T_BIG_REAL)); /* might be a number, but not complex (quaternion) */ - f = find_method(sc, find_let(sc, p), sc->is_complex_symbol); + f = find_method_with_let(sc, p, sc->is_complex_symbol); if ((f != sc->undefined) && (is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))))) return(big_type_to_result_type(result_type, T_BIG_COMPLEX)); @@ -91064,7 +91410,7 @@ static s7_pointer big_divide(s7_scheme *sc, s7_pointer args) { s7_pointer func; if ((has_active_methods(sc, car(x))) && - ((func = find_method(sc, find_let(sc, car(x)), sc->multiply_symbol)) != sc->undefined)) + ((func = find_method_with_let(sc, car(x), sc->multiply_symbol)) != sc->undefined)) { divisor = s7_apply_function(sc, func, cons(sc, divisor, x)); break; @@ -92310,7 +92656,7 @@ static bool is_integer_via_method(s7_scheme *sc, s7_pointer p) if (has_active_methods(sc, p)) { s7_pointer f; - f = find_method(sc, find_let(sc, p), sc->is_integer_symbol); + f = find_method_with_let(sc, p, sc->is_integer_symbol); if (f != sc->undefined) return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil)))); } @@ -93422,7 +93768,7 @@ static s7_pointer set_bignum_precision(s7_scheme *sc, int32_t precision) { mp_prec_t bits; if (precision <= 1) /* (set! (*s7* 'bignum-precision) 1) causes mpfr to segfault! (also 0 and -1) */ - return(s7_out_of_range_error(sc, "set! (*s7* 'bignum-precision)", 0, wrap_integer1(sc, precision), "has to be greater than 1")); + return(s7_out_of_range_error(sc, "set! (*s7* 'bignum-precision)", 0, wrap_integer2(sc, precision), "has to be greater than 1")); bits = (mp_prec_t)precision; mpfr_set_default_prec(bits); @@ -94472,7 +94818,7 @@ static bool is_decodable(s7_scheme *sc, s7_pointer p) } for (i = 0; i < NUM_CHARS; i++) if (p == chars[i]) return(true); - for (i = 0; i <= NUM_SMALL_INTS; i++) if (p == small_ints[i]) return(true); + for (i = 0; i < NUM_SMALL_INTS; i++) if (p == small_ints[i]) return(true); /* also real_one and friends, sc->safe_lists, p|elist? */ /* check the heap */ @@ -94588,6 +94934,166 @@ char *s7_decode_bt(s7_scheme *sc) /* -------------------------------- initialization -------------------------------- */ +static void fx_function_init(void) +{ + int32_t i; + for (i = 0; i < NUM_OPS; i++) + fx_function[i] = NULL; + + fx_function[HOP_SAFE_C_D] = fx_c_d; + + fx_function[HOP_SAFE_C_S] = fx_c_s; + fx_function[HOP_SAFE_C_opDq] = fx_c_opdq; + fx_function[HOP_SAFE_C_opSq] = fx_c_opsq; + fx_function[HOP_SAFE_C_opSSq] = fx_c_opssq; + fx_function[HOP_SAFE_C_opSCq] = fx_c_opscq; + fx_function[HOP_SAFE_C_opCSq] = fx_c_opcsq; + + fx_function[HOP_SAFE_C_SC] = fx_c_sc; + fx_function[HOP_SAFE_C_CS] = fx_c_cs; + fx_function[HOP_SAFE_C_CQ] = fx_c_cq; + fx_function[HOP_SAFE_C_SS] = fx_c_ss; + + fx_function[HOP_SAFE_C_opSq_S] = fx_c_opsq_s; + fx_function[HOP_SAFE_C_opSq_C] = fx_c_opsq_c; + fx_function[HOP_SAFE_C_opSq_CS] = fx_c_opsq_cs; + fx_function[HOP_SAFE_C_S_opSq] = fx_c_s_opsq; + fx_function[HOP_SAFE_C_S_opDq] = fx_c_s_opdq; + fx_function[HOP_SAFE_C_opDq_S] = fx_c_opdq_s; + fx_function[HOP_SAFE_C_C_opSq] = fx_c_c_opsq; + fx_function[HOP_SAFE_C_C_opDq] = fx_c_c_opdq; + fx_function[HOP_SAFE_C_opCSq_C] = fx_c_opcsq_c; + fx_function[HOP_SAFE_C_opCSq_S] = fx_c_opcsq_s; + fx_function[HOP_SAFE_C_C_opCSq] = fx_c_c_opcsq; + fx_function[HOP_SAFE_C_S_opCSq] = fx_c_s_opcsq; + fx_function[HOP_SAFE_C_opSSq_C] = fx_c_opssq_c; + fx_function[HOP_SAFE_C_opSCq_C] = fx_c_opscq_c; + fx_function[HOP_SAFE_C_opSSq_S] = fx_c_opssq_s; + fx_function[HOP_SAFE_C_S_opSSq] = fx_c_s_opssq; + fx_function[HOP_SAFE_C_C_opSSq] = fx_c_c_opssq; + fx_function[HOP_SAFE_C_S_opSCq] = fx_c_s_opscq; + fx_function[HOP_SAFE_C_C_opSCq] = fx_c_c_opscq; + fx_function[HOP_SAFE_C_opSq_opSq] = fx_c_opsq_opsq; + fx_function[HOP_SAFE_C_opSq_opSSq] = fx_c_opsq_opssq; + fx_function[HOP_SAFE_C_opSSq_opSq] = fx_c_opssq_opsq; + fx_function[HOP_SAFE_C_opSSq_opSSq] = fx_c_opssq_opssq; + fx_function[HOP_SAFE_C_op_opSSqq_C] = fx_c_op_opssqq_c; + fx_function[HOP_SAFE_C_op_opSqq] = fx_c_op_opsqq; + fx_function[HOP_SAFE_C_op_opSq_Cq] = fx_c_op_opsq_cq; + fx_function[HOP_SAFE_C_op_opSqq_C] = fx_c_op_opsqq_c; + fx_function[HOP_SAFE_C_op_S_opSqq] = fx_c_op_s_opsqq; + fx_function[HOP_SAFE_C_op_opSq_Sq] = fx_c_op_opsq_sq; + fx_function[HOP_SAFE_C_S_op_S_opSqq] = fx_c_s_op_s_opsqq; + fx_function[HOP_SAFE_C_S_op_S_opSSqq] = fx_c_s_op_s_opssqq; + fx_function[HOP_SAFE_C_S_op_opSq_Cq] = fx_c_s_op_opsq_cq; + fx_function[HOP_SAFE_C_op_opSSqq_S] = fx_c_op_opssqq_s; + fx_function[HOP_SAFE_C_op_opSSq_Sq_S] = fx_c_op_opssq_sq_s; + fx_function[HOP_SAFE_C_S_op_opSSq_opSSqq] = fx_c_s_op_opssq_opssqq; + + fx_function[OP_SAFE_C_TUS] = fx_c_tus; + fx_function[HOP_SAFE_C_SSC] = fx_c_ssc; + fx_function[HOP_SAFE_C_SSS] = fx_c_sss; + fx_function[HOP_SAFE_C_SCS] = fx_c_scs; + fx_function[HOP_SAFE_C_SCC] = fx_c_scc; + fx_function[HOP_SAFE_C_CSS] = fx_c_css; + fx_function[HOP_SAFE_C_CSC] = fx_c_csc; + fx_function[HOP_SAFE_C_CCS] = fx_c_ccs; + fx_function[HOP_SAFE_C_ALL_S] = fx_c_all_s; + + fx_function[HOP_SAFE_C_A] = fx_c_a; + fx_function[HOP_SAFE_C_AA] = fx_c_aa; + fx_function[HOP_SAFE_C_CA] = fx_c_ca; + fx_function[HOP_SAFE_C_AC] = fx_c_ac; + fx_function[HOP_SAFE_C_AAA] = fx_c_aaa; + fx_function[HOP_SAFE_C_CAC] = fx_c_cac; + fx_function[HOP_SAFE_C_CSA] = fx_c_csa; + fx_function[HOP_SAFE_C_SCA] = fx_c_sca; + fx_function[HOP_SAFE_C_SAS] = fx_c_sas; + fx_function[HOP_SAFE_C_SSA] = fx_c_ssa; + fx_function[HOP_SAFE_C_ALL_CA] = fx_c_all_ca; + fx_function[HOP_SAFE_C_FX] = fx_c_fx; + fx_function[HOP_SAFE_C_4A] = fx_c_4a; + fx_function[HOP_SAFE_C_opAq] = fx_c_opaq; + fx_function[HOP_SAFE_C_opAAq] = fx_c_opaaq; + fx_function[HOP_SAFE_C_opAAAq] = fx_c_opaaaq; + fx_function[HOP_SAFE_C_opAq_S] = fx_c_opaq_s; + fx_function[HOP_SAFE_C_S_opAq] = fx_c_s_opaq; + fx_function[HOP_SAFE_C_S_opAAq] = fx_c_s_opaaq; + fx_function[HOP_SAFE_C_S_opAAAq] = fx_c_s_opaaaq; + + fx_function[HOP_SAFE_THUNK_A] = fx_safe_thunk_a; + fx_function[HOP_SAFE_CLOSURE_S_A] = fx_safe_closure_s_a; + fx_function[HOP_SAFE_CLOSURE_A_A] = fx_safe_closure_a_a; + fx_function[HOP_SAFE_CLOSURE_SS_A] = fx_safe_closure_ss_a; + fx_function[HOP_SAFE_CLOSURE_AA_A] = fx_safe_closure_aa_a; + fx_function[HOP_SAFE_CLOSURE_3S_A] = fx_safe_closure_3s_a; + + fx_function[OP_SSA_DIRECT] = fx_c_ssa_direct; + fx_function[OP_HASH_INCREMENT] = fx_hash_increment; + + fx_function[HOP_SAFE_CLOSURE_S_TO_S] = fx_safe_closure_s_to_s; + fx_function[HOP_SAFE_CLOSURE_S_TO_SC] = fx_safe_closure_s_to_sc; + fx_function[HOP_SAFE_CLOSURE_A_TO_SC] = fx_safe_closure_a_to_sc; + + fx_function[OP_COND_FX_FX] = fx_cond_fx_fx; + fx_function[OP_opIF_A_SSq_A] = fx_opif_a_ssq_a; + fx_function[OP_IF_A_CC] = fx_if_a_cc; + fx_function[OP_IF_A_A] = fx_if_a_a; + fx_function[OP_IF_S_AA] = fx_if_s_aa; + fx_function[OP_IF_A_AA] = fx_if_a_aa; + fx_function[OP_IF_AND2_SA] = fx_if_and2_sa; + fx_function[OP_IF_NOT_A_A] = fx_if_not_a_a; + fx_function[OP_IF_NOT_A_AA] = fx_if_not_a_aa; + fx_function[OP_OR_2] = fx_or_2; + fx_function[OP_OR_S_2] = fx_or_s_2; + fx_function[OP_OR_S_TYPE_2] = fx_or_s_type_2; + fx_function[OP_OR_3] = fx_or_3; + fx_function[OP_OR_N] = fx_or_n; + fx_function[OP_AND_2] = fx_and_2; + fx_function[OP_AND_S_2] = fx_and_s_2; + fx_function[OP_AND_3] = fx_and_3; + fx_function[OP_AND_N] = fx_and_n; + fx_function[OP_LET_TEMP_A_A] = fx_let_temp_a_a; + + fx_function[OP_TC_AND_A_OR_A_LA] = fx_tc_and_a_or_a_la; + fx_function[OP_TC_OR_A_AND_A_LA] = fx_tc_or_a_and_a_la; + fx_function[OP_TC_OR_A_A_AND_A_A_LA] = fx_tc_or_a_a_and_a_a_la; + fx_function[OP_TC_AND_A_OR_A_LAA] = fx_tc_and_a_or_a_laa; + fx_function[OP_TC_OR_A_AND_A_LAA] = fx_tc_or_a_and_a_laa; + fx_function[OP_TC_AND_A_OR_A_A_LA] = fx_tc_and_a_or_a_a_la; + fx_function[OP_TC_IF_A_Z_LA] = fx_tc_if_a_z_la; + fx_function[OP_TC_IF_A_LA_Z] = fx_tc_if_a_la_z; + fx_function[OP_TC_IF_A_Z_LAA] = fx_tc_if_a_z_laa; + fx_function[OP_TC_IF_A_LAA_Z] = fx_tc_if_a_laa_z; + fx_function[OP_TC_IF_A_Z_L3A] = fx_tc_if_a_z_l3a; + fx_function[OP_TC_IF_A_L3A_Z] = fx_tc_if_a_l3a_z; + fx_function[OP_TC_IF_A_Z_IF_A_Z_LA] = fx_tc_if_a_z_if_a_z_la; + fx_function[OP_TC_COND_A_Z_A_Z_LA] = fx_tc_cond_a_z_a_z_la; + fx_function[OP_TC_IF_A_Z_IF_A_LA_Z] = fx_tc_if_a_z_if_a_la_z; + fx_function[OP_TC_IF_A_Z_IF_A_LAA_Z] = fx_tc_if_a_z_if_a_laa_z; + fx_function[OP_TC_IF_A_Z_IF_A_Z_LAA] = fx_tc_if_a_z_if_a_z_laa; + fx_function[OP_TC_IF_A_Z_IF_A_L3A_L3A] = fx_tc_if_a_z_if_a_l3a_l3a; + fx_function[OP_TC_COND_A_Z_A_Z_LAA] = fx_tc_cond_a_z_a_z_laa; + fx_function[OP_TC_CASE_LA] = fx_tc_case_la; + fx_function[OP_TC_OR_A_AND_A_A_L3A] = fx_tc_or_a_and_a_a_l3a; + fx_function[OP_TC_IF_A_T_AND_A_A_L3A] = fx_tc_if_a_t_and_a_a_l3a; + fx_function[OP_TC_LET_IF_A_Z_LAA] = fx_tc_let_if_a_z_laa; + fx_function[OP_TC_LET_WHEN_LAA] = fx_tc_let_when_laa; + fx_function[OP_TC_LET_UNLESS_LAA] = fx_tc_let_unless_laa; + fx_function[OP_TC_LET_COND] = fx_tc_let_cond; + fx_function[OP_TC_COND_A_Z_A_LAA_LAA] = fx_tc_cond_a_z_a_laa_laa; + + fx_function[OP_RECUR_IF_A_A_opA_LAq] = fx_recur_if_a_a_opa_laq; + fx_function[OP_RECUR_IF_A_opA_LAq_A] = fx_recur_if_a_opa_laq_a; + fx_function[OP_RECUR_IF_A_A_AND_A_LAA_LAA] = fx_recur_if_a_a_and_a_laa_laa; + fx_function[OP_RECUR_COND_A_A_A_A_opLA_LAq] = fx_recur_cond_a_a_a_a_opla_laq; +} + +#if WITH_FX_TREE +#include "fx_tree.h" +#endif + + static s7_pointer make_real_wrapper(void) { s7_pointer p; @@ -94822,6 +95328,9 @@ s7_scheme *s7_init(void) sc->temp9 = sc->nil; sc->temp10 = sc->nil; + sc->rec_p1 = sc->F; + sc->rec_p2 = sc->F; + sc->begin_hook = NULL; sc->autoload_table = sc->nil; sc->autoload_names = NULL; @@ -94903,6 +95412,9 @@ s7_scheme *s7_init(void) o = &os[i]; sc->opts[i] = o; o->sc = sc; +#if S7_DEBUGGING + o->loc = i; +#endif } } @@ -95694,7 +96206,6 @@ s7_scheme *s7_init(void) set_scope_safe(slot_value(global_slot(sc->with_input_from_file_symbol))); set_scope_safe(slot_value(global_slot(sc->with_output_to_string_symbol))); set_scope_safe(slot_value(global_slot(sc->with_output_to_file_symbol))); - set_scope_safe(slot_value(global_slot(sc->set_cdr_symbol))); set_maybe_safe(slot_value(global_slot(sc->assoc_symbol))); set_scope_safe(slot_value(global_slot(sc->assoc_symbol))); set_maybe_safe(slot_value(global_slot(sc->member_symbol))); @@ -95710,7 +96221,8 @@ s7_scheme *s7_init(void) set_scope_safe(slot_value(global_slot(sc->throw_symbol))); set_scope_safe(slot_value(global_slot(sc->error_symbol))); set_scope_safe(slot_value(global_slot(sc->apply_values_symbol))); - set_scope_safe(slot_value(global_slot(sc->list_values_symbol))); + /* set_scope_safe(slot_value(global_slot(sc->set_cdr_symbol))); */ /* now safe */ + /* set_scope_safe(slot_value(global_slot(sc->list_values_symbol))); */ /* now safe */ sc->tree_leaves_symbol = defun("tree-leaves", tree_leaves, 1, 0, false); sc->tree_memq_symbol = defun("tree-memq", tree_memq, 2, 0, false); @@ -95780,9 +96292,13 @@ s7_scheme *s7_init(void) sc->local_setter_symbol = make_symbol(sc, "+setter+"); sc->local_iterator_symbol = make_symbol(sc, "+iterator+"); - /* for backwards compatibility */ +#if (!DISABLE_DEPRECATED) s7_define_constant(sc, "nan.0", real_NaN); s7_define_constant(sc, "inf.0", real_infinity); +#else + s7_define_variable(sc, "nan.0", real_NaN); + s7_define_variable(sc, "inf.0", real_infinity); +#endif #if WITH_PURE_S7 s7_provide(sc, "pure-s7"); @@ -96070,6 +96586,7 @@ s7_scheme *s7_init(void) #if (!WITH_GMP) s7_set_p_pp_function(slot_value(global_slot(sc->remainder_symbol)), remainder_p_pp); + s7_set_p_pp_function(slot_value(global_slot(sc->quotient_symbol)), quotient_p_pp); s7_set_i_i_function(slot_value(global_slot(sc->abs_symbol)), abs_i_i); s7_set_d_d_function(slot_value(global_slot(sc->abs_symbol)), abs_d_d); s7_set_d_d_function(slot_value(global_slot(sc->exp_symbol)), exp_d_d); @@ -96089,10 +96606,6 @@ s7_scheme *s7_init(void) s7_set_d_dd_function(slot_value(global_slot(sc->atan_symbol)), atan_d_dd); s7_set_d_7dd_function(slot_value(global_slot(sc->remainder_symbol)), remainder_d_7dd); s7_set_d_dd_function(slot_value(global_slot(sc->modulo_symbol)), modulo_d_dd); - s7_set_p_pp_function(slot_value(global_slot(sc->multiply_symbol)), multiply_p_pp); - s7_set_p_dd_function(slot_value(global_slot(sc->multiply_symbol)), mul_p_dd); - s7_set_p_dd_function(slot_value(global_slot(sc->add_symbol)), add_p_dd); - s7_set_p_dd_function(slot_value(global_slot(sc->subtract_symbol)), sub_p_dd); s7_set_i_7d_function(slot_value(global_slot(sc->round_symbol)), round_i_7d); s7_set_i_7d_function(slot_value(global_slot(sc->floor_symbol)), floor_i_7d); s7_set_i_7p_function(slot_value(global_slot(sc->floor_symbol)), floor_i_7p); @@ -96104,6 +96617,13 @@ s7_scheme *s7_init(void) s7_set_i_7ii_function(slot_value(global_slot(sc->remainder_symbol)), remainder_i_7ii); s7_set_i_ii_function(slot_value(global_slot(sc->modulo_symbol)), modulo_i_ii); s7_set_p_d_function(slot_value(global_slot(sc->rationalize_symbol)), rationalize_p_d); + s7_set_p_pp_function(slot_value(global_slot(sc->add_symbol)), add_p_pp); + s7_set_p_pp_function(slot_value(global_slot(sc->subtract_symbol)), subtract_p_pp); + s7_set_p_pp_function(slot_value(global_slot(sc->divide_symbol)), divide_p_pp); + s7_set_p_pp_function(slot_value(global_slot(sc->multiply_symbol)), multiply_p_pp); + s7_set_p_dd_function(slot_value(global_slot(sc->multiply_symbol)), mul_p_dd); + s7_set_p_dd_function(slot_value(global_slot(sc->add_symbol)), add_p_dd); + s7_set_p_dd_function(slot_value(global_slot(sc->subtract_symbol)), sub_p_dd); #endif s7_set_p_d_function(slot_value(global_slot(sc->float_vector_symbol)), float_vector_p_d); s7_set_p_i_function(slot_value(global_slot(sc->int_vector_symbol)), int_vector_p_i); @@ -96124,10 +96644,6 @@ s7_scheme *s7_init(void) s7_set_d_dddd_function(slot_value(global_slot(sc->multiply_symbol)), multiply_d_dddd); s7_set_p_i_function(slot_value(global_slot(sc->divide_symbol)), divide_p_i); s7_set_p_ii_function(slot_value(global_slot(sc->divide_symbol)), divide_p_ii); -#if (!WITH_GMP) - s7_set_p_pp_function(slot_value(global_slot(sc->add_symbol)), add_p_pp); - s7_set_p_pp_function(slot_value(global_slot(sc->subtract_symbol)), subtract_p_pp); -#endif s7_set_d_dd_function(slot_value(global_slot(sc->max_symbol)), max_d_dd); s7_set_d_dd_function(slot_value(global_slot(sc->min_symbol)), min_d_dd); s7_set_d_ddd_function(slot_value(global_slot(sc->max_symbol)), max_d_ddd); @@ -96248,6 +96764,7 @@ s7_scheme *s7_init(void) s7_set_p_p_function(slot_value(global_slot(sc->list_symbol)), list_p_p); s7_set_p_pp_function(slot_value(global_slot(sc->list_symbol)), list_p_pp); s7_set_p_ppp_function(slot_value(global_slot(sc->list_symbol)), list_p_ppp); + s7_set_p_pp_function(slot_value(global_slot(sc->list_tail_symbol)), list_tail_p_pp); s7_set_p_pp_function(slot_value(global_slot(sc->assq_symbol)), assq_p_pp); s7_set_p_pp_function(slot_value(global_slot(sc->memq_symbol)), memq_p_pp); s7_set_p_p_function(slot_value(global_slot(sc->tree_leaves_symbol)), tree_leaves_p_p); @@ -96259,6 +96776,7 @@ s7_scheme *s7_init(void) s7_set_p_p_function(slot_value(global_slot(sc->c_pointer_weak2_symbol)), c_pointer_weak2_p_p); s7_set_p_p_function(slot_value(global_slot(sc->is_char_alphabetic_symbol)), is_char_alphabetic_p_p); s7_set_p_p_function(slot_value(global_slot(sc->is_char_whitespace_symbol)), is_char_whitespace_p_p); + s7_set_p_p_function(slot_value(global_slot(sc->read_char_symbol)), read_char_p_p); s7_set_p_i_function(slot_value(global_slot(sc->make_string_symbol)), make_string_p_i); s7_set_p_ii_function(slot_value(global_slot(sc->make_int_vector_symbol)), make_int_vector_p_ii); s7_set_p_ii_function(slot_value(global_slot(sc->make_byte_vector_symbol)), make_byte_vector_p_ii); @@ -96273,10 +96791,13 @@ s7_scheme *s7_init(void) #if (!WITH_GMP) s7_set_b_i_function(slot_value(global_slot(sc->is_zero_symbol)), is_zero_i); s7_set_b_d_function(slot_value(global_slot(sc->is_zero_symbol)), is_zero_d); + s7_set_p_p_function(slot_value(global_slot(sc->magnitude_symbol)), magnitude_p_p); #endif s7_set_p_p_function(slot_value(global_slot(sc->is_zero_symbol)), is_zero_p_p); s7_set_p_p_function(slot_value(global_slot(sc->is_positive_symbol)), is_positive_p_p); s7_set_p_p_function(slot_value(global_slot(sc->is_negative_symbol)), is_negative_p_p); + s7_set_p_p_function(slot_value(global_slot(sc->real_part_symbol)), real_part_p_p); + s7_set_p_p_function(slot_value(global_slot(sc->imag_part_symbol)), imag_part_p_p); s7_set_b_i_function(slot_value(global_slot(sc->is_positive_symbol)), is_positive_i); s7_set_b_d_function(slot_value(global_slot(sc->is_positive_symbol)), is_positive_d); s7_set_b_i_function(slot_value(global_slot(sc->is_negative_symbol)), is_negative_i); @@ -96334,6 +96855,7 @@ s7_scheme *s7_init(void) s7_set_b_pi_function(slot_value(global_slot(sc->geq_symbol)), geq_b_pi); s7_set_p_pi_function(slot_value(global_slot(sc->add_symbol)), g_add_xi); + s7_set_p_pi_function(slot_value(global_slot(sc->subtract_symbol)), g_sub_xi); s7_set_p_pi_function(slot_value(global_slot(sc->multiply_symbol)), g_mul_xi); /* s7_set_p_pd_function(slot_value(global_slot(sc->add_symbol)), g_add_xf); */ /* no ip pd dp! */ @@ -96395,7 +96917,7 @@ s7_scheme *s7_init(void) #endif /* -------------------------------------------------------------------------------- */ - s7_define_macro(sc, "quasiquote", g_quasiquote, 1, 0, false, H_quasiquote); + sc->quasiquote_symbol = s7_define_macro(sc, "quasiquote", g_quasiquote, 1, 0, false, H_quasiquote); #if (!WITH_PURE_S7) s7_eval_c_string(sc, "(define-macro (call-with-values producer consumer) (list consumer (list producer)))"); @@ -96511,7 +97033,7 @@ s7_scheme *s7_init(void) if (strcmp(op_names[HOP_SAFE_C_PP], "h_safe_c_pp") != 0) fprintf(stderr, "c op_name: %s\n", op_names[HOP_SAFE_C_PP]); if (strcmp(op_names[OP_SET_WITH_LET_2], "set_with_let_2") != 0) fprintf(stderr, "set op_name: %s\n", op_names[OP_SET_WITH_LET_2]); if (strcmp(op_names[OP_SAFE_CLOSURE_A_A], "safe_closure_a_a") != 0) fprintf(stderr, "clo op_name: %s\n", op_names[OP_SAFE_CLOSURE_A_A]); - if (NUM_OPS != 855) fprintf(stderr, "size: cell: %d, block: %d, max op: %d, opt: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS, (int)sizeof(opt_info)); + if (NUM_OPS != 880) fprintf(stderr, "size: cell: %d, block: %d, max op: %d, opt: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS, (int)sizeof(opt_info)); /* 64 bit machine: cell size: 48, 80 if gmp, 160 if debugging, block size: 40, opt: 128 */ #endif @@ -96523,9 +97045,9 @@ s7_scheme *s7_init(void) s7_eval_c_string(sc, "(begin \n\ (define-constant most-positive-fixnum (*s7* 'most-positive-fixnum)) \n\ (define-constant most-negative-fixnum (*s7* 'most-negative-fixnum)) \n\ - (define global-environment rootlet) \n\ + (define global-environment rootlet) \n\ (define current-environment curlet) \n\ - (define make-keyword string->keyword))"); /* these are used in CM's scm/s7.scm */ + (define make-keyword string->keyword))"); /* these are used in CM's scm/s7.scm */ #endif return(sc); @@ -96541,37 +97063,120 @@ s7_scheme *s7_init(void) #define WITH_MAIN 0 #endif +static void dumb_repl(s7_scheme *sc) +{ + while (true) + { + char buffer[512]; + fprintf(stdout, "\n> "); + if (!fgets(buffer, 512, stdin)) break; /* error or ctrl-D */ + if (((buffer[0] != '\n') || (strlen(buffer) > 1))) + { + char response[1024]; + snprintf(response, 1024, "(write %s)", buffer); + s7_eval_c_string(sc, response); + } + } + fprintf(stdout, "\n"); + if (ferror(stdin)) + fprintf(stderr, "read error on stdin\n"); +} + +void s7_repl(s7_scheme *sc) +{ + s7_pointer old_e, e, val; + s7_int gc_loc; + /* try to get lib_s7.so from the repl's directory, and set *libc*. + * otherwise repl.scm will try to load libc.scm which will try to build libc_s7.so locally, but that requires s7.h + */ + e = s7_inlet(sc, s7_list(sc, 2, s7_make_symbol(sc, "init_func"), s7_make_symbol(sc, "libc_s7_init"))); + gc_loc = s7_gc_protect(sc, e); + old_e = s7_set_curlet(sc, e); /* e is now (curlet) so loaded names from libc will be placed there, not in (rootlet) */ + val = s7_load_with_environment(sc, "libc_s7.so", e); + s7_define_variable(sc, "*libc*", e); + s7_eval_c_string(sc, "(set! *libraries* (cons (cons \"libc.scm\" *libc*) *libraries*))"); + s7_gc_unprotect_at(sc, gc_loc); + s7_set_curlet(sc, old_e); /* restore incoming (curlet) */ + if (!val) + dumb_repl(sc); + else + { + s7_load(sc, "repl.scm"); + s7_eval_c_string(sc, "((*repl* 'run))"); + } +} + #if (WITH_MAIN && (!USE_SND)) +#if (!MS_WINDOWS) +static char *realdir(const char *filename) /* this code courtesy Lassi Kortela 4-Nov-19 */ +{ + char *path; + char *p; + /* s7_repl wants to load libc_s7.o (for tcsetattr et al), but if it is started in a directory other than the libc_s7.so + * directory, it fails (it tries to build the library but that requires s7.h and libc.scm). So here we are trying to + * guess the libc_s7 directory from the command line program name. This can't work in general, but it works often + * enough to be worth the effort. If S7_LOAD_PATH is set, it is used instead. + */ + if (!strchr(filename, '/')) + { + if (!file_probe("libc_s7.so")) + { + fprintf(stderr, "%s needs libc_s7.so (give the explicit pathname)\n", filename); /* env PATH=/home/bil/cl repl */ + exit(2); + } + return(NULL); /* we're in the libc_s7.so directory, I hope (local s7 might not match local libc_s7.so) */ + } + if (!(path = realpath(filename, NULL))) + { + fprintf(stderr, "%s: %s\n", strerror(errno), filename); + exit(2); + } + if (!(p = strrchr(path, '/'))) + { + free(path); + fprintf(stderr, "please provide the full pathname for %s\n", filename); + exit(2); + } + if (p > path) *p = '\0'; else p[1] = 0; + return(path); +} +#endif + int main(int argc, char **argv) { s7_scheme *sc; sc = s7_init(); + fprintf(stderr, "s7: %s\n", S7_DATE); + if (argc == 2) { fprintf(stderr, "load %s\n", argv[1]); - s7_load(sc, argv[1]); + if (!s7_load(sc, argv[1])) + { + fprintf(stderr, "can't load %s\n", argv[1]); + return(2); + } } else { -#if (!MS_WINDOWS) - s7_load(sc, "repl.scm"); /* this is libc dependent */ - s7_eval_c_string(sc, "((*repl* 'run))"); +#if MS_WINDOWS + dumb_repl(sc); +#else +#ifdef S7_LOAD_PATH + s7_add_to_load_path(sc, S7_LOAD_PATH); #else - while (1) /* a minimal repl -- taken from s7.html */ + char *dir; + dir = realdir(argv[0]); + if (dir) { - char buffer[512]; - char response[1024]; - fprintf(stdout, "\n> "); - fgets(buffer, 512, stdin); - if ((buffer[0] != '\n') || (strlen(buffer) > 1)) - { - snprintf(response, 1024, "(write %s)", buffer); - s7_eval_c_string(sc, response); - } + s7_add_to_load_path(sc, dir); + free(dir); } #endif + s7_repl(sc); +#endif } return(0); } @@ -96588,64 +97193,61 @@ int main(int argc, char **argv) * * new snd version: snd.h configure.ac HISTORY.Snd NEWS barchive diffs, /usr/ccrma/web/html/software/snd/index.html * - * ------------------------------------------------------------------------------ - * 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19.7 19.8 19.9 - * ------------------------------------------------------------------------------ - * tpeak | | | | 391 | 377 | 199 | 163 163 - * tauto | | | 1752 | 1689 | 1700 | 835 | 630 621 - * tref | | | 2372 | 2125 | 1036 | 983 | 876 791 - * tshoot | | | | | | 1224 | 847 - * index 44.3 | 3291 | 1725 | 1276 | 1255 | 1168 | 1022 | 880 876 - * teq | | | 6612 | 2777 | 1931 | 1539 | 1485 1479 - * s7test 1721 | 1358 | 995 | 1194 | 2926 | 2110 | 1726 | 1685 1674 - * tvect | | | | | | 5729 | 1919 1793 - * tmisc | | | | | | 2636 | 1949 1846 - * lint | | | | 4041 | 2702 | 2120 | 2090 2053 - * tlet | | | | | 4717 | 2959 | 2241 2148 - * tform | | | 6816 | 3714 | 2762 | 2362 | 2238 2207 - * tcopy | | | 13.6 | 3183 | 2974 | 2320 | 2251 2220 - * tread | | | | | 2357 | 2336 | 2258 2264 - * tclo | | 4391 | 4666 | 4651 | 4682 | 3084 | 2626 2397 - * tmat 8641 | 8458 | | 7279 | 7248 | 7252 | 6823 | 2655 2463 - * fbench 4123 | 3869 | 3486 | 3609 | 3602 | 3637 | 3495 | 2681 2653 - * titer | | | | 5971 | 4646 | 3587 | 2828 2727 - * trclo | | | | 10.3 | 10.5 | 8758 | 2886 2820 - * tmap | | | 9.3 | 5279 | 3445 | 3015 | 3049 2897 - * tset | | | | | 10.0 | 6432 | 2980 2928 - * tsort | | | | 8584 | 4111 | 3327 | 3236 3090 - * dup | | | | | 20.8 | 5711 | 3028 3362 - * tmac 8550 | 8396 | 7556 | 5606 | 5503 | 5404 | 3969 | 3624 3514 - * tfft | | 17.1 | 17.3 | 19.2 | 19.3 | 4466 | 4029 3873 - * trec 35.0 | 29.3 | 24.8 | 25.5 | 24.9 | 25.6 | 20.0 | 6435 6432 - * thash | | | | | | 10.3 | 8467 6647 - * tgen | 71.0 | 70.6 | 38.0 | 12.6 | 11.9 | 11.2 | 10.8 10.8 - * tall 90.0 | 43.0 | 14.5 | 12.7 | 17.9 | 18.8 | 17.1 | 14.8 14.6 - * calls 359.0 |275.0 | 54.0 | 34.7 | 43.7 | 40.4 | 38.4 | 35.6 35.1 - * sg | | | |139.0 | 85.9 | 78.0 | 69.1 68.6 - * lg | | | |211.0 |133.0 |112.7 |106.8 103.8 - * tbig | | | | |246.9 |230.6 |181.2 177.9 - * ------------------------------------------------------------------------------ - * - * glistener, gtk-script, s7.html for gtk4, grepl.c gcall.c gcall2.c? - * grepl compiles but the various key_press events are not valid, gtk-script appears to be ok - * wayland needs work - * - * gcc/clang have builtin __int128 or __int128_t and __uint128_t, use #if defined(__SIZEOF_INT128__)...#endif - * also __float128 -> s7_big_int|double + * -------------------------------------------------------------------------- + * 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19.9 | + * -------------------------------------------------------------------------- + * tpeak | | | | 391 | 377 | 199 | 112 | + * tauto | | | 1752 | 1689 | 1700 | 835 | 623 | + * tref | | | 2372 | 2125 | 1036 | 983 | 715 | + * tshoot | | | | | | 1224 | 735 | + * index 44.3 | 3291 | 1725 | 1276 | 1255 | 1168 | 1022 | 866 | + * teq | | | 6612 | 2777 | 1931 | 1539 | 1447 | + * tvect | | | | | | 5729 | 1617 | + * s7test 1721 | 1358 | 995 | 1194 | 2926 | 2110 | 1726 | 1680 | + * lint | | | | 4041 | 2702 | 2120 | 2038 | + * tlet | | | | | 4717 | 2959 | 2123 | + * tform | | | 6816 | 3714 | 2762 | 2362 | 2205 | + * tcopy | | | 13.6 | 3183 | 2974 | 2320 | 2225 | + * tread | | | | | 2357 | 2336 | 2256 | + * tmisc | | | | | | 3087 | 2298 | + * tmat 8641 | 8458 | | 7279 | 7248 | 7252 | 6823 | 2399 | + * dup | | | | | 20.8 | 5711 | 2576 | + * trclo | | | | 10.3 | 10.5 | 8758 | 2601 | + * fbench 4123 | 3869 | 3486 | 3609 | 3602 | 3637 | 3495 | 2613 | + * titer | | | | 5971 | 4646 | 3587 | 2687 | + * tmap | | | 9.3 | 5279 | 3445 | 3015 | 2725 | + * tb | | | 4727 | 4742 | 4735 | 3481 | 2739 | + * tset | | | | | 10.0 | 6432 | 2922 | + * tsort | | | | 8584 | 4111 | 3327 | 2935 | + * tmac 8550 | 8396 | 7556 | 5606 | 5503 | 5404 | 3969 | 3139 | + * tfft | | 17.1 | 17.3 | 19.2 | 19.3 | 4466 | 3727 | + * tclo | | 9502 | 10.0 | 9730 | 9729 | 6848 | 4676 | + * trec 35.0 | 29.3 | 24.8 | 25.5 | 24.9 | 25.6 | 20.0 | 5949 | + * thash | | | | | | 10.3 | 6497 | + * tgen | 71.0 | 70.6 | 38.0 | 12.6 | 11.9 | 11.2 | 10.8 | + * tall 90.0 | 43.0 | 14.5 | 12.7 | 17.9 | 18.8 | 17.1 | 14.3 | + * calls 359.0 |275.0 | 54.0 | 34.7 | 43.7 | 40.4 | 38.4 | 34.6 | + * sg | | | |139.0 | 85.9 | 78.0 | 68.2 | + * lg | | | |211.0 |133.0 |112.7 |103.1 | + * tbig | | | | |246.9 |230.6 |176.8 177.8 see tmp + * -------------------------------------------------------------------------- * - * fx*direct p_pp opts, opt_set_p_i_f* call make_integer, also p_d_f - * split format as per s7.html, can optimizer catch no string result cases? - * split add|mul_p_pp -- aren't there splittable pp cases? add_p_pi ip pd dp and mul/-/= [di id?] - * op_c_s_opssq_direct -> add should notice int-vector et al and use add_p_xx? - * no ip dp pd yet - * perhaps hash-table-default [where to store it? -- add room in block data?] - * need timing for rats/complex -- make sure rats stay that way: continued fractions (t184) - * replace closure_id_s with all_s? = (define x y) but done stupidly, 71533 - * fx_sqr_1 using t [let* first?] ftree opssq_s? -- wrong order? - * (t180=overheads) - * check (named-)let(*) for optimize_lambda, but letrec(*) is safer since outlet is blocked here [these need tests] - * closure_s_to_opscq_c? - * if all opts[pc] refs gone at runtime, can all pc++ be removed? [267(+44?) o->sc->pc++][9|56 ++o...] - * can o_wrap be finessed via b_to_p_0 et al? [28? cases] - * direct op|fx_safe_c_s|s? + * opt* coverage tests t206 opt_i|d|p* + * main allocations: frames+slots, arglists: use scope_safe with closure? or needs_copied_args? where is this happening? + * lambda arg ok if self-contained + * op_named_let_fx (arg list is not needed, pick out lamlet case?), op_safe_c_fp (try gx below? or recog possibility in opt) + * make frame first in place of list + * for fp-style local lists, use a vector instead? or a cons+opt1... (arglen<6 but needs mv support?) + * also gx_call? op_safe_closure_s_a->check+call else jump(back to fp caller) as in no fx_call case, could include unknown* call + * gx_functions? or gx_checks+fx_function given hop bit + * applies to ap, pa etc, safe_closure_p_a + * first var in op_named_let cases + * ? tc: if_a_z_let_if_a_z_la + * direct? fx_c_aa(sg) opsq_c(lg: lint_let_ref?) sa(lg) aaa(lg/b): need rest of cxr cases + * there are lots of offsets in fx* -- cdaddr etc + * move bignum checks into vref et al [is_eq_s_vref for example] + * vector max-len is s7_int, so even in gmp case the indices need to fit s7_int (so vector_ref_p_pp needs bignum cases) + * combiner for opt funcs (pp/pi etc) [p_p+p_pp to p_d+d_dd...][p_any|p|d|i|b = cf_opt_any now] + * cp->ca but should be cp->c_opssq (combine_ops sees this case)? sa in big also (via multiply_sa) + * t718 */ |